June 2026 - ghc-commits

[Git][ghc/ghc][master] libraries/process: bump submodule to v1.6.30.0
by Marge Bot (＠marge-bot) 13 Jun '26

13 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d9ea2d76 by mangoiv at 2026-06-13T04:41:51-04:00 libraries/process: bump submodule to v1.6.30.0 - bump the submodule to the appropriate tag - suppress benign warning resulting from the change - - - - - 2 changed files: - libraries/process - testsuite/driver/testlib.py Changes: ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 +Subproject commit 11fd247ad33208da7a914acf15d4a09d64a6a4c4 ===================================== testsuite/driver/testlib.py ===================================== @@ -3066,11 +3066,15 @@ def normalise_errmsg(s: str) -> str: # Old emcc warns when we export HEAP8 but new one requires it (see #26290) s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nwarning: invalid item in EXPORTED_RUNTIME_METHODS: HEAPU8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','') - # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, - # however, these are completely benign stubs. - # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 if opsys('darwin'): + # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, + # however, these are completely benign stubs. + # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 s = modify_lines(s, lambda l: re.sub(r'.*ranlib:.*has no symbols', '', l)) + # we also want to remove linker warnings having to do with undefined dynamic_lookup in combination with + # making a single weak symbol undefined as this is dependent on other linker flags + # See also https://github.com/haskell/process/pull/377 + s = drop_lines_containing(s, 'ld: warning: -U option is redundant when using -undefined dynamic_lookup') return s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d9ea2d76545452a7df567b162340079… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d9ea2d76545452a7df567b162340079… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T27379
by Simon Jakobi (＠sjakobi2) 13 Jun '26

13 Jun '26

Simon Jakobi pushed new branch wip/sjakobi/T27379 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T27379 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: libraries/process: bump submodule to v1.6.30.0
by Marge Bot (＠marge-bot) 13 Jun '26

13 Jun '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: dc14443b by mangoiv at 2026-06-12T19:40:34-04:00 libraries/process: bump submodule to v1.6.30.0 - bump the submodule to the appropriate tag - suppress benign warning resulting from the change - - - - - 18b1d7f7 by David Eichmann at 2026-06-12T19:40:34-04:00 ghc-toolchain: don't throw when candidate executables are not found Fixes #27369 - - - - - f1b098bc by David Eichmann at 2026-06-12T19:40:35-04:00 CI: lint-changelog checks for no-changelog label in script instead of rules - - - - - 5 changed files: - .gitlab-ci.yml - libraries/process - testsuite/driver/testlib.py - utils/ghc-toolchain/src/GHC/Toolchain/Program.hs - utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs Changes: ===================================== .gitlab-ci.yml ===================================== @@ -255,6 +255,9 @@ lint-changelog: BUILD_FLAVOUR: default CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID" script: + # Cancel the job if there is a no-changelog label + - | + [[ ",${CI_MERGE_REQUEST_LABELS}," == *",no-changelog,"* ]] && exit 0 # Check that the MR adds at least one changelog entry - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" "$CI_MERGE_REQUEST_TARGET_BRANCH_NAME" - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)" @@ -274,8 +277,6 @@ lint-changelog: rules: - if: '$CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/' when: never - - if: '$CI_MERGE_REQUEST_LABELS =~ /.*no-changelog.*/' - when: never - if: $CI_MERGE_REQUEST_ID - *drafts-can-fail-lint ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 +Subproject commit 11fd247ad33208da7a914acf15d4a09d64a6a4c4 ===================================== testsuite/driver/testlib.py ===================================== @@ -3066,11 +3066,15 @@ def normalise_errmsg(s: str) -> str: # Old emcc warns when we export HEAP8 but new one requires it (see #26290) s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nwarning: invalid item in EXPORTED_RUNTIME_METHODS: HEAPU8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','') - # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, - # however, these are completely benign stubs. - # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 if opsys('darwin'): + # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, + # however, these are completely benign stubs. + # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 s = modify_lines(s, lambda l: re.sub(r'.*ranlib:.*has no symbols', '', l)) + # we also want to remove linker warnings having to do with undefined dynamic_lookup in combination with + # making a single weak symbol undefined as this is dependent on other linker flags + # See also https://github.com/haskell/process/pull/377 + s = drop_lines_containing(s, 'ld: warning: -U option is redundant when using -undefined dynamic_lookup') return s ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Program.hs ===================================== @@ -148,12 +148,14 @@ findProgram description userSpec candidates Just prefix -> map (prefix++) candidates Nothing -> [] candidates' = prefixedCandidates ++ candidates - err = - [ "Failed to find " ++ description ++ "." - , "Looked for one of " ++ show candidates' ++ " in the system search path." - ] - path <- oneOf' err (map findExecutableErr candidates') - return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) } + pathMay <- findM doesExecutableExist candidates' + case pathMay of + Nothing -> throwEs + [ "Failed to find " ++ description ++ "." + , "Looked for one of " ++ show candidates' ++ " in the system search path." + ] + Just path -> + return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) } -- Note that @configure.ac@ checks these llvm version constants (using @sed@) to -- ensure they are the same as the @$LlvmMinVersion@ and @$LlvmMaxVersion@ @@ -222,21 +224,18 @@ maybeFindProgramFromProgOpts :: String -> ProgOpt -> Maybe (M Program) maybeFindProgramFromProgOpts description userSpec = case poPath userSpec of Nothing -> Nothing Just path -> Just $ do - let err = - [ "Failed to find " ++ description ++ "." - , "Looked for user-specified program '" ++ path ++ "' in the system search path." - ] - path' <- findExecutableErr path <|> throwEs err - return Program { prgPath = path', prgFlags = fromMaybe [] (poFlags userSpec) } - -findExecutableErr :: String -> M FilePath -findExecutableErr name = do - r <- liftIO $ findExecutable name - case r of - Nothing -> throwE $ name ++ " not found in search path" - -- Use the given `prgPath` or candidate name rather than the - -- absolute path returned by `findExecutable`. - Just _x -> return name + exists <- doesExecutableExist path + unless exists $ throwEs + [ "Failed to find " ++ description ++ "." + , "Looked for user-specified program '" ++ path ++ "' in the system search path." + ] + return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) } + +doesExecutableExist + :: String -- ^ executable name + -> M Bool +doesExecutableExist name = isJust <$> liftIO (findExecutable name) + -------------------- Compiling utilities -------------------- ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs ===================================== @@ -9,6 +9,7 @@ module GHC.Toolchain.Utils , oneOf' , isSuccess , lastLine + , findM ) where import Control.Exception @@ -69,3 +70,10 @@ isSuccess = \case lastLine :: String -> String lastLine = maybe "" snd . unsnoc . lines + +findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) +findM f = \case + [] -> return Nothing + a:as -> do + found <- f a + if found then return (Just a) else findM f as View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9426fd1f2616cb63135b0c9dc97ce8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9426fd1f2616cb63135b0c9dc97ce8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Add type family performance test for #26426
by Marge Bot (＠marge-bot) 13 Jun '26

13 Jun '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 40764930 by sheaf at 2026-06-12T14:54:43-04:00 Add type family performance test for #26426 Some GHC versions produced large numbers of coercions after typechecking and desugaring when compiling the program in #26426: Version | Typechecker time | Typechecker allocations | Coercions -------:|-----------------:|------------------------:|---------: 9.6 | 47 ms | 48 MB | 110k 9.8 | 1000 ms | 486 MB | 10,437k 9.10 | 922 ms | 489 MB | 10,436k 9.12 | 906 ms | 482 MB | 10,437k 9.14 | 63 ms | 55 MB | 333k 10.0 | 47 ms | 64 MB | 35k The improvement 9.12 -> 9.14 was due to commit 22d11fa818fae2c95c494fc0fac1f8cb4c6e7cb6, while the improvement 9.14 -> 10.0 was due to commit 0b7df6db9e46df40e86fbff1a66dc10440b99db5. As the behaviour of GHC seems better than it's ever been on this program, we declare victory, adding this performance test to ensure we don't regress on this program. On the way, we update Note [Combining equalities] in GHC.Tc.SolveR.Equality with the explanation of the 9.12 -> 9.14 improvement (getting rid of an exponential blowup in coercion sizes), and we update Note [Exploiting closed type families] in GHC.Tc.Solver.FunDeps with the explanation of the 9.14 -> 10.0 improvement (bringing down coercion size growth from cubic to quadratic). - - - - - 0f3d0a71 by Zubin Duggal at 2026-06-12T14:55:30-04:00 compiler: mark tool messages as errors/warnings depending on the exit code Fixes #27370 - - - - - acfc184b by mangoiv at 2026-06-12T15:28:59-04:00 libraries/process: bump submodule to v1.6.30.0 - bump the submodule to the appropriate tag - suppress benign warning resulting from the change - - - - - d1b8a9c2 by David Eichmann at 2026-06-12T15:28:59-04:00 ghc-toolchain: don't throw when candidate executables are not found Fixes #27369 - - - - - 9426fd1f by David Eichmann at 2026-06-12T15:29:00-04:00 CI: lint-changelog checks for no-changelog label in script instead of rules - - - - - 16 changed files: - .gitlab-ci.yml - + changelog.d/tool-messages-27370 - compiler/GHC/SysTools/Process.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/FunDeps.hs - libraries/process - testsuite/driver/testlib.py - + testsuite/tests/driver/T27370/Makefile - + testsuite/tests/driver/T27370/T27370.hs - + testsuite/tests/driver/T27370/T27370.pp - + testsuite/tests/driver/T27370/T27370.stderr - + testsuite/tests/driver/T27370/all.T - + testsuite/tests/perf/compiler/T26426.hs - testsuite/tests/perf/compiler/all.T - utils/ghc-toolchain/src/GHC/Toolchain/Program.hs - utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs Changes: ===================================== .gitlab-ci.yml ===================================== @@ -255,6 +255,9 @@ lint-changelog: BUILD_FLAVOUR: default CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID" script: + # Cancel the job if there is a no-changelog label + - | + [[ ",${CI_MERGE_REQUEST_LABELS}," == *",no-changelog,"* ]] && exit 0 # Check that the MR adds at least one changelog entry - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" "$CI_MERGE_REQUEST_TARGET_BRANCH_NAME" - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)" @@ -274,8 +277,6 @@ lint-changelog: rules: - if: '$CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/' when: never - - if: '$CI_MERGE_REQUEST_LABELS =~ /.*no-changelog.*/' - when: never - if: $CI_MERGE_REQUEST_ID - *drafts-can-fail-lint ===================================== changelog.d/tool-messages-27370 ===================================== @@ -0,0 +1,6 @@ +section: compiler +synopsis: Mark messages from external tools as errors or warnings depending on + the tool's exit code. Previously, output printed to stderr by tools was + unconditionally reported as errors. +issues: #27370 +mrs: !16170 ===================================== compiler/GHC/SysTools/Process.hs ===================================== @@ -26,8 +26,9 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Utils.CliOption -import GHC.Driver.Errors (reportError) +import GHC.Driver.Errors (reportDiagnostic) +import GHC.Types.Error ( DiagnosticReason(..) ) import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) import GHC.Data.FastString @@ -271,9 +272,10 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea getLocaleEncoding >>= hSetEncoding readEnd hSetNewlineMode readEnd nativeNewlineMode hSetBuffering readEnd LineBuffering - messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd - mapM_ processBuildMessage messages - waitForProcess hProcess + messages <- parseBuildMessages . filter_fn . lines <$> hGetContents' readEnd + code <- waitForProcess hProcess + mapM_ (processBuildMessage code) messages + return code hClose hStdIn case r of Left (SomeException e) -> do @@ -282,13 +284,16 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea Right s -> do return s where - processBuildMessage :: BuildMessage -> IO () - processBuildMessage msg = do + processBuildMessage :: ExitCode -> BuildMessage -> IO () + processBuildMessage code msg = do case msg of BuildMsg msg -> do logInfo logger $ withPprStyle defaultUserStyle msg BuildError loc msg -> do - reportError logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) msg + let reason = case code of + ExitSuccess -> WarningWithoutFlag + ExitFailure{} -> ErrorWithoutFlag + reportDiagnostic logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) reason msg parseBuildMessages :: [String] -> [BuildMessage] parseBuildMessages str = loop str Nothing ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -2980,15 +2980,30 @@ But it's not so simple: we kick out g1. Now we have two constraints [W] g1 : F a ~ a Int (arising from (F a ~ a Int)) [W] g2{rw:g1} : F a ~ a Int (arising from (F alpha ~ F a)) - If we end up with g2 in the inert set (not g1) we'll get a very confusing - error message that we can solve (F a ~ a Int) - arising from F a ~ F a + If we solve `g1` from `g2` we end up with + g1 := g2 + [W] g2{} : F a ~ a Int (arising from (F alpha ~ F a)) + and hence (since alpha := a) we report that we can't solve (F a ~ a Int) + arising from (F a ~ F a), which is extremely confusing. Moreover, it seems + wrong to "solve" `g1` using `g2` when `g2` has itself been rewritten by `g1`! TL;DR: Better to hang on to `g1` (with no rewriters), in preference to `g2` (which has a rewriter). See (WRW11) in Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint. + + Note that the decision to prefer a constraint without rewriters over one that + has rewriters can also have a /huge/ effect on performance. For instance, it + avoids an **exponential** blow-up in the size of coercions produced when + typechecking in T26426. In that program, we have coercions of the form: + + co_i :: TaggedTypes as `Append` TaggedTypes '[ty] + ~# TaggedTypes (as `Append` '[ty]) + + and each 'co_{i+1}' contains the previous 'co_i' twice. Without preferring + Wanteds with no rewriters, we essentially end up inlining 'co_i' into 'co_{i+1}', + which results in exponentially-sized proof terms, growing like O(2^i). -} tryInertEqs :: EqCt -> SolverStage () ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -1198,6 +1198,56 @@ Key point: equations that are not relevant do not need to be considered for fund and [W] I alpha ~ Int |> g2 Here we definiteily want to take advantage of injectivity. +(CF6) This machinery can also have a significant positive effect on the size of + proof terms. For example (simplification of T26426): + + type family (++) a b where { '[] ++ ys = ys; (x:xs) ++ ys = x : (xs ++ ys) } + type family MapId a where { MapId '[] = '[]; MapId (x:xs) = x : MapId xs } + + app :: (MapId xs ++ MapId ys ~ MapId (xs ++ ys)) => Proxy xs -> Proxy ys -> Proxy (xs ++ ys) + + test :: Proxy [ty_1, ..., ty_n] + test = Proxy @'[ty_1] + `app` Proxy @'[ty_2] + ... + `app` Proxy @'[ty_n] + + Every `app` call gives rise to a Wanted of the form: + + [W] MapId acc_i ++ MapId '[ty_i] ~ MapId (acc_i ++ '[ty_i]) + + while the overall result type gives us a Wanted of the form + + [W] acc_n ++ '[ty_n] ~ [ty_1, ..., ty_n] + + By using (CFFA) on this result Wanted, we deduce that we must have + + acc_n ~ [ty_1, ..., ty_{n-1}] + + which is a flat list. Repeating the process, (CFFA) allows us to deduce that + + acc_i ~ [ty_1, ..., ty_{i-1}] + + for all i. This allows the other Wanteds to be solved directly, giving rise to + proof terms with the typical triangular O(n^2) shape + + co_i = (O(i) proof that MapId acc_i ++ MapId '[ty_i] ~ acc_{i+1}) + ; (O(i) proof that acc_{i+1} ~ MapId (acc_i ++ '[ty_i])) + + However, /without/ (CFFA), 'acc_i' is not unified with a flat list but is left + as the nested application: + + acc_i ~ (... (('[ty_1] ++ '[ty_2]) ++ '[ty_3]) ... ++ '[ty_{i-1}]) + + This means that 'MapId acc_i' is stuck until we reduce the above, which takes + O(i^2) type family reduction steps, instead of O(i). The same applies to + the other proof term involving 'MapId (acc_i ++ '[ty_i])'. + Consequently, without (CFFA) the overall coercion size blows up to O(n^3). + + The takeaway is that (CFFA) allows us to push in the (flat) result type, + instead of relying on recursively built sub-proof terms, which brings down + coercion sizes (in certain situations) from O(n^3) to O(n^2). + Note [Cache-caused loops] ~~~~~~~~~~~~~~~~~~~~~~~~~ It is very dangerous to cache a rewritten wanted family equation as 'solved' in ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 +Subproject commit 11fd247ad33208da7a914acf15d4a09d64a6a4c4 ===================================== testsuite/driver/testlib.py ===================================== @@ -3066,11 +3066,15 @@ def normalise_errmsg(s: str) -> str: # Old emcc warns when we export HEAP8 but new one requires it (see #26290) s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nwarning: invalid item in EXPORTED_RUNTIME_METHODS: HEAPU8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','') - # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, - # however, these are completely benign stubs. - # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 if opsys('darwin'): + # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, + # however, these are completely benign stubs. + # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 s = modify_lines(s, lambda l: re.sub(r'.*ranlib:.*has no symbols', '', l)) + # we also want to remove linker warnings having to do with undefined dynamic_lookup in combination with + # making a single weak symbol undefined as this is dependent on other linker flags + # See also https://github.com/haskell/process/pull/377 + s = drop_lines_containing(s, 'ld: warning: -U option is redundant when using -undefined dynamic_lookup') return s ===================================== testsuite/tests/driver/T27370/Makefile ===================================== @@ -0,0 +1,7 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T27370: + chmod +x ./T27370.pp + '$(TEST_HC)' $(TEST_HC_OPTS) -c T27370.hs ===================================== testsuite/tests/driver/T27370/T27370.hs ===================================== @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF ./T27370.pp #-} +module T27370 where ===================================== testsuite/tests/driver/T27370/T27370.pp ===================================== @@ -0,0 +1,5 @@ +#!/bin/sh +cp "$2" "$3" +echo "$1:2:8: a located warning from an external tool" +echo " with a continuation line" +echo "an unlocated line from an external tool" ===================================== testsuite/tests/driver/T27370/T27370.stderr ===================================== @@ -0,0 +1,5 @@ +T27370.hs:2:8: warning: + a located warning from an external tool + with a continuation line + +an unlocated line from an external tool ===================================== testsuite/tests/driver/T27370/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27370', + [extra_files(['T27370.hs', 'T27370.pp']), + when(opsys('mingw32'), skip)], + makefile_test, ['T27370']) ===================================== testsuite/tests/perf/compiler/T26426.hs ===================================== @@ -0,0 +1,66 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +module T26426 ( + someTypes +) where + +import Data.Kind (Type) +import GHC.TypeLits (Symbol) + +type family Append (left :: [k]) (right :: [k]) :: [k] where + Append '[] right = right + Append (a : rest) right = a : Append rest right + +type family TaggedTypes (tags :: [(Symbol, Type)]) :: [Type] where + TaggedTypes '[] = '[] + TaggedTypes ('(_, typ) : rest) = typ : TaggedTypes rest + +data Types (types :: [(Symbol, Type)]) = Types + +mkTypes :: forall sym val. val -> Types '[ '(sym, val) ] +mkTypes _ = Types + +appendTypes :: + -- This constraint is the one that causes the issue. If the next line is commented + -- out, then this module compiles quickly + Append (TaggedTypes left) (TaggedTypes right) ~ TaggedTypes (Append left right) => + Types left -> Types right -> Types (Append left right) +appendTypes _ _ = Types + +someTypes :: + Types + [ '("01", Int) + , '("02", Int) + , '("03", Int) + , '("04", Int) + , '("05", Int) + , '("06", Int) + , '("07", Int) + , '("08", Int) + , '("09", Int) + , '("10", Int) + , '("11", Int) + , '("12", Int) + , '("13", Int) + , '("14", Int) + , '("15", Int) + , '("16", Int) + ] + +someTypes = + mkTypes @"01" 1 `appendTypes` + mkTypes @"02" 2 `appendTypes` + mkTypes @"03" 3 `appendTypes` + mkTypes @"04" 4 `appendTypes` + mkTypes @"05" 5 `appendTypes` + mkTypes @"06" 6 `appendTypes` + mkTypes @"07" 7 `appendTypes` + mkTypes @"08" 8 `appendTypes` + mkTypes @"09" 9 `appendTypes` + mkTypes @"10" 10 `appendTypes` + mkTypes @"11" 11 `appendTypes` + mkTypes @"12" 12 `appendTypes` + mkTypes @"13" 13 `appendTypes` + mkTypes @"14" 14 `appendTypes` + mkTypes @"15" 15 `appendTypes` + mkTypes @"16" 16 ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -87,6 +87,13 @@ test('T783', ], compile,['']) +test ('T26426' + , [ only_ways(['normal']) + , collect_compiler_stats('bytes allocated',4) ] + , compile + , [''] + ) + test('T5321Fun', [ only_ways(['normal']), # no optimisation for this one collect_compiler_runtime(2), ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Program.hs ===================================== @@ -148,12 +148,14 @@ findProgram description userSpec candidates Just prefix -> map (prefix++) candidates Nothing -> [] candidates' = prefixedCandidates ++ candidates - err = - [ "Failed to find " ++ description ++ "." - , "Looked for one of " ++ show candidates' ++ " in the system search path." - ] - path <- oneOf' err (map findExecutableErr candidates') - return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) } + pathMay <- findM doesExecutableExist candidates' + case pathMay of + Nothing -> throwEs + [ "Failed to find " ++ description ++ "." + , "Looked for one of " ++ show candidates' ++ " in the system search path." + ] + Just path -> + return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) } -- Note that @configure.ac@ checks these llvm version constants (using @sed@) to -- ensure they are the same as the @$LlvmMinVersion@ and @$LlvmMaxVersion@ @@ -222,21 +224,18 @@ maybeFindProgramFromProgOpts :: String -> ProgOpt -> Maybe (M Program) maybeFindProgramFromProgOpts description userSpec = case poPath userSpec of Nothing -> Nothing Just path -> Just $ do - let err = - [ "Failed to find " ++ description ++ "." - , "Looked for user-specified program '" ++ path ++ "' in the system search path." - ] - path' <- findExecutableErr path <|> throwEs err - return Program { prgPath = path', prgFlags = fromMaybe [] (poFlags userSpec) } - -findExecutableErr :: String -> M FilePath -findExecutableErr name = do - r <- liftIO $ findExecutable name - case r of - Nothing -> throwE $ name ++ " not found in search path" - -- Use the given `prgPath` or candidate name rather than the - -- absolute path returned by `findExecutable`. - Just _x -> return name + exists <- doesExecutableExist path + unless exists $ throwEs + [ "Failed to find " ++ description ++ "." + , "Looked for user-specified program '" ++ path ++ "' in the system search path." + ] + return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) } + +doesExecutableExist + :: String -- ^ executable name + -> M Bool +doesExecutableExist name = isJust <$> liftIO (findExecutable name) + -------------------- Compiling utilities -------------------- ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs ===================================== @@ -9,6 +9,7 @@ module GHC.Toolchain.Utils , oneOf' , isSuccess , lastLine + , findM ) where import Control.Exception @@ -69,3 +70,10 @@ isSuccess = \case lastLine :: String -> String lastLine = maybe "" snd . unsnoc . lines + +findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) +findM f = \case + [] -> return Nothing + a:as -> do + found <- f a + if found then return (Just a) else findM f as View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/396d6f0e7708ca4d6982b1ad320207… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/396d6f0e7708ca4d6982b1ad320207… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] compiler: mark tool messages as errors/warnings depending on the exit code
by Marge Bot (＠marge-bot) 13 Jun '26

13 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0f3d0a71 by Zubin Duggal at 2026-06-12T14:55:30-04:00 compiler: mark tool messages as errors/warnings depending on the exit code Fixes #27370 - - - - - 7 changed files: - + changelog.d/tool-messages-27370 - compiler/GHC/SysTools/Process.hs - + testsuite/tests/driver/T27370/Makefile - + testsuite/tests/driver/T27370/T27370.hs - + testsuite/tests/driver/T27370/T27370.pp - + testsuite/tests/driver/T27370/T27370.stderr - + testsuite/tests/driver/T27370/all.T Changes: ===================================== changelog.d/tool-messages-27370 ===================================== @@ -0,0 +1,6 @@ +section: compiler +synopsis: Mark messages from external tools as errors or warnings depending on + the tool's exit code. Previously, output printed to stderr by tools was + unconditionally reported as errors. +issues: #27370 +mrs: !16170 ===================================== compiler/GHC/SysTools/Process.hs ===================================== @@ -26,8 +26,9 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Utils.CliOption -import GHC.Driver.Errors (reportError) +import GHC.Driver.Errors (reportDiagnostic) +import GHC.Types.Error ( DiagnosticReason(..) ) import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) import GHC.Data.FastString @@ -271,9 +272,10 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea getLocaleEncoding >>= hSetEncoding readEnd hSetNewlineMode readEnd nativeNewlineMode hSetBuffering readEnd LineBuffering - messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd - mapM_ processBuildMessage messages - waitForProcess hProcess + messages <- parseBuildMessages . filter_fn . lines <$> hGetContents' readEnd + code <- waitForProcess hProcess + mapM_ (processBuildMessage code) messages + return code hClose hStdIn case r of Left (SomeException e) -> do @@ -282,13 +284,16 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea Right s -> do return s where - processBuildMessage :: BuildMessage -> IO () - processBuildMessage msg = do + processBuildMessage :: ExitCode -> BuildMessage -> IO () + processBuildMessage code msg = do case msg of BuildMsg msg -> do logInfo logger $ withPprStyle defaultUserStyle msg BuildError loc msg -> do - reportError logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) msg + let reason = case code of + ExitSuccess -> WarningWithoutFlag + ExitFailure{} -> ErrorWithoutFlag + reportDiagnostic logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) reason msg parseBuildMessages :: [String] -> [BuildMessage] parseBuildMessages str = loop str Nothing ===================================== testsuite/tests/driver/T27370/Makefile ===================================== @@ -0,0 +1,7 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T27370: + chmod +x ./T27370.pp + '$(TEST_HC)' $(TEST_HC_OPTS) -c T27370.hs ===================================== testsuite/tests/driver/T27370/T27370.hs ===================================== @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF ./T27370.pp #-} +module T27370 where ===================================== testsuite/tests/driver/T27370/T27370.pp ===================================== @@ -0,0 +1,5 @@ +#!/bin/sh +cp "$2" "$3" +echo "$1:2:8: a located warning from an external tool" +echo " with a continuation line" +echo "an unlocated line from an external tool" ===================================== testsuite/tests/driver/T27370/T27370.stderr ===================================== @@ -0,0 +1,5 @@ +T27370.hs:2:8: warning: + a located warning from an external tool + with a continuation line + +an unlocated line from an external tool ===================================== testsuite/tests/driver/T27370/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27370', + [extra_files(['T27370.hs', 'T27370.pp']), + when(opsys('mingw32'), skip)], + makefile_test, ['T27370']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f3d0a714f5c95a86506bb91360c67e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f3d0a714f5c95a86506bb91360c67e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add type family performance test for #26426
by Marge Bot (＠marge-bot) 13 Jun '26

13 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 40764930 by sheaf at 2026-06-12T14:54:43-04:00 Add type family performance test for #26426 Some GHC versions produced large numbers of coercions after typechecking and desugaring when compiling the program in #26426: Version | Typechecker time | Typechecker allocations | Coercions -------:|-----------------:|------------------------:|---------: 9.6 | 47 ms | 48 MB | 110k 9.8 | 1000 ms | 486 MB | 10,437k 9.10 | 922 ms | 489 MB | 10,436k 9.12 | 906 ms | 482 MB | 10,437k 9.14 | 63 ms | 55 MB | 333k 10.0 | 47 ms | 64 MB | 35k The improvement 9.12 -> 9.14 was due to commit 22d11fa818fae2c95c494fc0fac1f8cb4c6e7cb6, while the improvement 9.14 -> 10.0 was due to commit 0b7df6db9e46df40e86fbff1a66dc10440b99db5. As the behaviour of GHC seems better than it's ever been on this program, we declare victory, adding this performance test to ensure we don't regress on this program. On the way, we update Note [Combining equalities] in GHC.Tc.SolveR.Equality with the explanation of the 9.12 -> 9.14 improvement (getting rid of an exponential blowup in coercion sizes), and we update Note [Exploiting closed type families] in GHC.Tc.Solver.FunDeps with the explanation of the 9.14 -> 10.0 improvement (bringing down coercion size growth from cubic to quadratic). - - - - - 4 changed files: - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/FunDeps.hs - + testsuite/tests/perf/compiler/T26426.hs - testsuite/tests/perf/compiler/all.T Changes: ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -2980,15 +2980,30 @@ But it's not so simple: we kick out g1. Now we have two constraints [W] g1 : F a ~ a Int (arising from (F a ~ a Int)) [W] g2{rw:g1} : F a ~ a Int (arising from (F alpha ~ F a)) - If we end up with g2 in the inert set (not g1) we'll get a very confusing - error message that we can solve (F a ~ a Int) - arising from F a ~ F a + If we solve `g1` from `g2` we end up with + g1 := g2 + [W] g2{} : F a ~ a Int (arising from (F alpha ~ F a)) + and hence (since alpha := a) we report that we can't solve (F a ~ a Int) + arising from (F a ~ F a), which is extremely confusing. Moreover, it seems + wrong to "solve" `g1` using `g2` when `g2` has itself been rewritten by `g1`! TL;DR: Better to hang on to `g1` (with no rewriters), in preference to `g2` (which has a rewriter). See (WRW11) in Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint. + + Note that the decision to prefer a constraint without rewriters over one that + has rewriters can also have a /huge/ effect on performance. For instance, it + avoids an **exponential** blow-up in the size of coercions produced when + typechecking in T26426. In that program, we have coercions of the form: + + co_i :: TaggedTypes as `Append` TaggedTypes '[ty] + ~# TaggedTypes (as `Append` '[ty]) + + and each 'co_{i+1}' contains the previous 'co_i' twice. Without preferring + Wanteds with no rewriters, we essentially end up inlining 'co_i' into 'co_{i+1}', + which results in exponentially-sized proof terms, growing like O(2^i). -} tryInertEqs :: EqCt -> SolverStage () ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -1198,6 +1198,56 @@ Key point: equations that are not relevant do not need to be considered for fund and [W] I alpha ~ Int |> g2 Here we definiteily want to take advantage of injectivity. +(CF6) This machinery can also have a significant positive effect on the size of + proof terms. For example (simplification of T26426): + + type family (++) a b where { '[] ++ ys = ys; (x:xs) ++ ys = x : (xs ++ ys) } + type family MapId a where { MapId '[] = '[]; MapId (x:xs) = x : MapId xs } + + app :: (MapId xs ++ MapId ys ~ MapId (xs ++ ys)) => Proxy xs -> Proxy ys -> Proxy (xs ++ ys) + + test :: Proxy [ty_1, ..., ty_n] + test = Proxy @'[ty_1] + `app` Proxy @'[ty_2] + ... + `app` Proxy @'[ty_n] + + Every `app` call gives rise to a Wanted of the form: + + [W] MapId acc_i ++ MapId '[ty_i] ~ MapId (acc_i ++ '[ty_i]) + + while the overall result type gives us a Wanted of the form + + [W] acc_n ++ '[ty_n] ~ [ty_1, ..., ty_n] + + By using (CFFA) on this result Wanted, we deduce that we must have + + acc_n ~ [ty_1, ..., ty_{n-1}] + + which is a flat list. Repeating the process, (CFFA) allows us to deduce that + + acc_i ~ [ty_1, ..., ty_{i-1}] + + for all i. This allows the other Wanteds to be solved directly, giving rise to + proof terms with the typical triangular O(n^2) shape + + co_i = (O(i) proof that MapId acc_i ++ MapId '[ty_i] ~ acc_{i+1}) + ; (O(i) proof that acc_{i+1} ~ MapId (acc_i ++ '[ty_i])) + + However, /without/ (CFFA), 'acc_i' is not unified with a flat list but is left + as the nested application: + + acc_i ~ (... (('[ty_1] ++ '[ty_2]) ++ '[ty_3]) ... ++ '[ty_{i-1}]) + + This means that 'MapId acc_i' is stuck until we reduce the above, which takes + O(i^2) type family reduction steps, instead of O(i). The same applies to + the other proof term involving 'MapId (acc_i ++ '[ty_i])'. + Consequently, without (CFFA) the overall coercion size blows up to O(n^3). + + The takeaway is that (CFFA) allows us to push in the (flat) result type, + instead of relying on recursively built sub-proof terms, which brings down + coercion sizes (in certain situations) from O(n^3) to O(n^2). + Note [Cache-caused loops] ~~~~~~~~~~~~~~~~~~~~~~~~~ It is very dangerous to cache a rewritten wanted family equation as 'solved' in ===================================== testsuite/tests/perf/compiler/T26426.hs ===================================== @@ -0,0 +1,66 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +module T26426 ( + someTypes +) where + +import Data.Kind (Type) +import GHC.TypeLits (Symbol) + +type family Append (left :: [k]) (right :: [k]) :: [k] where + Append '[] right = right + Append (a : rest) right = a : Append rest right + +type family TaggedTypes (tags :: [(Symbol, Type)]) :: [Type] where + TaggedTypes '[] = '[] + TaggedTypes ('(_, typ) : rest) = typ : TaggedTypes rest + +data Types (types :: [(Symbol, Type)]) = Types + +mkTypes :: forall sym val. val -> Types '[ '(sym, val) ] +mkTypes _ = Types + +appendTypes :: + -- This constraint is the one that causes the issue. If the next line is commented + -- out, then this module compiles quickly + Append (TaggedTypes left) (TaggedTypes right) ~ TaggedTypes (Append left right) => + Types left -> Types right -> Types (Append left right) +appendTypes _ _ = Types + +someTypes :: + Types + [ '("01", Int) + , '("02", Int) + , '("03", Int) + , '("04", Int) + , '("05", Int) + , '("06", Int) + , '("07", Int) + , '("08", Int) + , '("09", Int) + , '("10", Int) + , '("11", Int) + , '("12", Int) + , '("13", Int) + , '("14", Int) + , '("15", Int) + , '("16", Int) + ] + +someTypes = + mkTypes @"01" 1 `appendTypes` + mkTypes @"02" 2 `appendTypes` + mkTypes @"03" 3 `appendTypes` + mkTypes @"04" 4 `appendTypes` + mkTypes @"05" 5 `appendTypes` + mkTypes @"06" 6 `appendTypes` + mkTypes @"07" 7 `appendTypes` + mkTypes @"08" 8 `appendTypes` + mkTypes @"09" 9 `appendTypes` + mkTypes @"10" 10 `appendTypes` + mkTypes @"11" 11 `appendTypes` + mkTypes @"12" 12 `appendTypes` + mkTypes @"13" 13 `appendTypes` + mkTypes @"14" 14 `appendTypes` + mkTypes @"15" 15 `appendTypes` + mkTypes @"16" 16 ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -87,6 +87,13 @@ test('T783', ], compile,['']) +test ('T26426' + , [ only_ways(['normal']) + , collect_compiler_stats('bytes allocated',4) ] + , compile + , [''] + ) + test('T5321Fun', [ only_ways(['normal']), # no optimisation for this one collect_compiler_runtime(2), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40764930f10d73f6ca00dfbbce908f9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40764930f10d73f6ca00dfbbce908f9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] rebindable for EPoll
by Rodrigo Mesquita (＠alt-romes) 13 Jun '26

13 Jun '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 6c4f54f9 by Rodrigo Mesquita at 2026-06-12T17:01:22+01:00 rebindable for EPoll - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc ===================================== @@ -22,6 +22,7 @@ module GHC.Internal.Event.EPoll ) where import qualified GHC.Internal.Event.Internal as E +import qualified GHC.Internal.Stack.Types as Rebindable import qualified GHC.Internal.Base as Rebindable -- For known-key names #include "EventConfig.h" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c4f54f938f1d405de0079980bffda8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c4f54f938f1d405de0079980bffda8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] 10 commits: Revert "Better specification for when to disable defaulting"
by Rodrigo Mesquita (＠alt-romes) 12 Jun '26

12 Jun '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: bffa37b8 by Rodrigo Mesquita at 2026-06-12T10:15:58+01:00 Revert "Better specification for when to disable defaulting" This reverts commit ac878ff32e63933b1f4268c7005129ebf3b85df6. - - - - - 54d9d6cf by Rodrigo Mesquita at 2026-06-12T10:22:23+01:00 undo changes to defaulting - - - - - 2495294b by Rodrigo Mesquita at 2026-06-12T14:21:37+01:00 Use structured error representation for missing GHC.Essentials Adds test T27013e to observe error - - - - - 43c33171 by Rodrigo Mesquita at 2026-06-12T14:35:48+01:00 augment err mesg - - - - - f7b1ed81 by Rodrigo Mesquita at 2026-06-12T15:13:29+01:00 fix augment - - - - - 0c2eb2d9 by Rodrigo Mesquita at 2026-06-12T16:05:10+01:00 Improve failure error when looking up the module directly And improve flag description, noting the implicit dependency. - - - - - def6b32e by Rodrigo Mesquita at 2026-06-12T16:09:04+01:00 SCS5 isSolvedWC fixes Num needed for composition - - - - - 5bb55594 by Rodrigo Mesquita at 2026-06-12T16:10:41+01:00 fixup! Improve failure error when looking up the module directly - - - - - b561913d by Rodrigo Mesquita at 2026-06-12T16:53:37+01:00 testsuite: -frebindable-known-names forces a dependency Therefore, to compile a module with -hide-all-packages, regardless of whether or not it uses known-names, we need -frebindable-known-names to tell GHC to not add that implicit dependency. Also a test that checks the error message when we don't have that flag. - - - - - 7e9c113b by Rodrigo Mesquita at 2026-06-12T16:57:03+01:00 typo - - - - - 18 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Types/Error/Codes.hs - docs/users_guide/separate_compilation.rst - testsuite/tests/cabal/T27013a/Makefile - testsuite/tests/cabal/T27013d/Makefile - + testsuite/tests/driver/T27013e/T27013e.hs - + testsuite/tests/driver/T27013e/T27013e.stderr - + testsuite/tests/driver/T27013e/all.T - + testsuite/tests/driver/T27013f/T27013f.hs - + testsuite/tests/driver/T27013f/T27013f.stderr - + testsuite/tests/driver/T27013f/all.T Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -372,11 +372,6 @@ Wrinkles keeps types and classes in the global type envt, but `Id`s in the local type envt. (Ids move to the global type env during zonking; see `zonkTopDecls`.) -(KN5) If we are not using -frebindable-known-names, yet GHC.Essentials is still not - in scope, then we don't add the `default Num (Integer, Double)` declaration - to the module being compiled. This relaxation makes it possible for a library - which does not use any known-key at all (namely: `composition`) to compile - successfully without a dependency on base nor ghc-internal. Note [Recipe for adding a known-occ name] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -25,6 +25,7 @@ module GHC.Iface.Errors.Ppr import GHC.Prelude import GHC.Builtin( knownKeyOccName_maybe ) +import GHC.Builtin.Modules( eSSENTIALS_NAME ) import GHC.Types.Error import GHC.Types.Hint.Ppr () -- Outputable GhcHint import GHC.Types.Error.Codes @@ -67,6 +68,7 @@ interfaceErrorHints = \ case MissingKnownKey2 {} -> noHints MissingKnownKey3 {} -> noHints KnownKeyScopeError {} -> noHints + CantFindEssentials {} -> noHints missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] missingInterfaceErrorHints = \case @@ -93,6 +95,7 @@ interfaceErrorReason (MissingKnownKey1 {}) = ErrorWithoutFlag interfaceErrorReason (MissingKnownKey2 {}) = ErrorWithoutFlag interfaceErrorReason (MissingKnownKey3 {}) = ErrorWithoutFlag interfaceErrorReason (KnownKeyScopeError {}) = ErrorWithoutFlag +interfaceErrorReason (CantFindEssentials {}) = ErrorWithoutFlag missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason missingInterfaceErrorReason = \ case @@ -321,6 +324,32 @@ interfaceErrorDiagnostic opts = \ case -> hang (text "Known-key entity" <+> quotes (ppr occ)) 2 (text "is ambiguous in the top-level global environment" $$ ppr gres) + CantFindEssentials err reason -> + vcat + [ vcat [ hang (text "Failed to load the known-names module" <+> quotes (ppr eSSENTIALS_NAME) <+> text "from the visible packages") + 2 (case reason of + UnknownLoadEssentialsReason -> empty + LookingForKnownOcc occ -> text "while looking for known-occ name" <+> quotes (ppr occ) + LookingForKnownKey key -> text "while looking for known-key" <+> quotes (pprKnownKey key) + LookingForEssentialsModule -> text "while trying to discover its package") + , text "Did you mean to use" <+> quotes (text "-package base") <> text "?" ] + , blankLine + , missingInterfaceErrorDiagnostic opts err + , blankLine + , case reason of + LookingForEssentialsModule + -> vcat [ text "This error was triggered while trying to discover the package of" <+> quotes (ppr eSSENTIALS_NAME) <> comma + , text "rather than when looking up any specific known-name." + , text "If you want to enforce" <+> quotes (ppr eSSENTIALS_NAME) <+> text "is not added to the module graph implicitly," + , text "you should use" <+> quotes (text "-frebindable-known-names") + ] + _ -> hang (text "To lookup known-names in scope rather than in GHC.Essentials" <> comma) + 2 (vcat [ text "use" <+> quotes (text "-frebindable-known-names") <> comma <+> text "and import" + , text "the necessary known-names definitions from" <+> quotes (text "ghc-internal") <> dot + -- Alternatively, you may want to unsafely provide your own GHC.Essentials exposing the known-names you need in scope." + ]) + ] + lookingForHerald :: InterfaceLookingFor -> SDoc lookingForHerald looking_for = case looking_for of ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -9,6 +9,7 @@ module GHC.Iface.Errors.Types ( , FindingModuleOrInterface(..) , BuildingCabalPackage(..) + , LoadEssentialsReason(..) , IfaceMessageOpts(..) @@ -70,6 +71,15 @@ data IfaceMessage -- We looked up a known-occ in the GlobalRdrEnv, -- but did not find a unique hit -- CallStack is so that we can get a backtrace + + | CantFindEssentials MissingInterfaceError LoadEssentialsReason + -- We failed to find GHC.Essentials, the module exported from base which + -- exports all the compiler known-names. The 'MissingInterfaceError' is + -- the underlying reason the module could not be found. A 'KnownKey' is + -- attached if we were looking for one when we failed to load GHC.Essentials + -- + -- Test cases: + -- tests/driver/T27013e deriving Generic data MissingInterfaceError @@ -113,3 +123,11 @@ data BuildingCabalPackage = YesBuildingCabalPackage | NoBuildingCabalPackage deriving Eq + +data LoadEssentialsReason + = LookingForKnownKey KnownKey + | LookingForKnownOcc KnownOcc + | LookingForEssentialsModule + | UnknownLoadEssentialsReason + deriving Generic + ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -73,7 +73,6 @@ import GHC.Iface.Binary import GHC.Iface.Rename import GHC.Iface.Env import GHC.Iface.Errors as Iface_Errors -import GHC.Iface.Errors.Ppr( defaultIfaceMessageOpts, missingInterfaceErrorDiagnostic ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad @@ -188,8 +187,12 @@ lookupKnownKeyName :: HasDebugCallStack => KnownKey -> KnownEntitySource -> IfM lcl (MaybeErr IfaceMessage Name) lookupKnownKeyName key KES_FromModule - = do { (kk_map, _) <- loadKnownKeyOccMaps - ; return $ lookupKnownKeysMap kk_map key } + = do { mb_maps <- loadKnownKeyOccMaps + ; return $ case mb_maps of + Failed (CantFindEssentials err UnknownLoadEssentialsReason) -- augment error + -> Failed (CantFindEssentials err (LookingForKnownKey key)) + Failed err -> Failed err + Succeeded (kk_map, _) -> lookupKnownKeysMap kk_map key } lookupKnownKeyName key (KES_InScope { ke_rdr_env = gbl_rdr_env }) -- Just gbl_rdr_env: we have -frebindable-known-names on, and @@ -240,10 +243,15 @@ lookupKnownOccName :: HasDebugCallStack => KnownOcc -> KnownEntitySource -> IfM lcl (MaybeErr IfaceMessage Name) lookupKnownOccName occ KES_FromModule - = do { (_, occ_map) <- loadKnownKeyOccMaps - ; case lookupOccEnv occ_map occ of - Just name -> return (Succeeded name) - Nothing -> return (Failed (MissingKnownKey3 occ)) } + = do { mb_maps <- loadKnownKeyOccMaps + ; return $ case mb_maps of + Failed (CantFindEssentials err UnknownLoadEssentialsReason) -- augment error + -> Failed (CantFindEssentials err (LookingForKnownOcc occ)) + Failed err -> Failed err + Succeeded (_, occ_map) -> + case lookupOccEnv occ_map occ of + Just name -> Succeeded name + Nothing -> Failed (MissingKnownKey3 occ) } lookupKnownOccName occ (KES_InScope { ke_rdr_env = gbl_rdr_env }) -- Just gbl_rdr_env: we have -frebindable-known-names on, and @@ -279,23 +287,29 @@ lookupKnownName kk_ns name where name_mod = nameModule name -loadKnownKeyOccMaps :: IfM lcl KnownKeyNameMaps +loadKnownKeyOccMaps :: IfM lcl (MaybeErr IfaceMessage KnownKeyNameMaps) loadKnownKeyOccMaps = do { eps <- getEps ; case eps_known_keys eps of { - Just (kk_maps, _) -> return kk_maps ; + Just (kk_maps, _) -> return (Succeeded kk_maps) ; Nothing -> -- We don't have a KnownKeyOccMap yet, so create it -- from the interface file for KnownKeyName do { hsc_env <- getTopEnv ; mb_res <- liftIO $ findImportedModule hsc_env eSSENTIALS_NAME NoPkgQual - ; iface <- case mb_res of - Found _ mod -> loadInterfaceWithException doc mod ImportBySystem - fr -> do { hsc_env <- getTopEnv - ; pprPanic "loadKnownKeyOccMap" $ - missingInterfaceErrorDiagnostic defaultIfaceMessageOpts $ - cannotFindModule hsc_env eSSENTIALS_NAME fr } + ; case mb_res of + Found _ mod -> Succeeded <$> build_maps mod + fr -> return (Failed (CantFindEssentials + (cannotFindModule hsc_env eSSENTIALS_NAME fr) + UnknownLoadEssentialsReason)) + } } } + where + doc = text "Need interface for KnownKeyNames" + + build_maps :: Module -> IfM lcl KnownKeyNameMaps + build_maps mod + = do { iface <- loadInterfaceWithException doc mod ImportBySystem ; let kk_map :: UniqFM KnownKey Name -- Domain is just the KnownKeys in the knownKeyTable @@ -318,9 +332,7 @@ loadKnownKeyOccMaps (msg $$ text "Known-key occ-map" <+> ppr occ_map) Nothing -> return () #endif - ; return (kk_map, occ_map) } } } - where - doc = text "Need interface for KnonwKeyNames" + ; return (kk_map, occ_map) } lookupKnownKeysMap :: UniqFM KnownKey Name -> KnownKey -> MaybeErr IfaceMessage Name lookupKnownKeysMap kk_map key = case lookupUFM kk_map key of @@ -361,10 +373,13 @@ lookupKnownKeysModule hsc_env dflags = do found_essentials <- findImportedModule hsc_env eSSENTIALS_NAME NoPkgQual let rebindable_kn = gopt Opt_RebindableKnownNames dflags let essentials_uid - | rebindable_kn = Nothing - | Found _ mod <- found_essentials = Just mod - | otherwise = Nothing - return essentials_uid + | rebindable_kn = return Nothing + | Found _ mod <- found_essentials = return (Just mod) + | fr <- found_essentials = do + throwOneError (initSourceErrorContext dflags) $ + mkPlainErrorMsgEnvelope noSrcSpan $ GhcDriverMessage $ DriverInterfaceError $ + CantFindEssentials (cannotFindModule hsc_env eSSENTIALS_NAME fr) LookingForEssentialsModule + essentials_uid {- ********************************************************************* * * ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -59,7 +59,7 @@ import GHC.Prelude import GHC.Iface.Load import GHC.Iface.Env -import GHC.Iface.Errors.Types( IfaceMessage(..) ) +import GHC.Iface.Errors.Types( IfaceMessage(..), LoadEssentialsReason (..) ) import GHC.Hs import GHC.Types.Name.Reader @@ -1044,10 +1044,15 @@ lookup_known_occ :: HasDebugCallStack => KnownEntitySource -> KnownOcc -> RnM (MaybeErr IfaceMessage Name) lookup_known_occ KES_FromModule occ - = do { (_, occ_map) <- initIfaceTcRn loadKnownKeyOccMaps - ; case lookupOccEnv occ_map occ of - Just name -> return (Succeeded name) - Nothing -> return (Failed (MissingKnownKey3 occ)) } + = do { mb_maps <- initIfaceTcRn loadKnownKeyOccMaps + ; return $ case mb_maps of + Failed (CantFindEssentials err UnknownLoadEssentialsReason) -- augment error + -> Failed (CantFindEssentials err (LookingForKnownOcc occ)) + Failed err -> Failed err + Succeeded (_, occ_map) -> + case lookupOccEnv occ_map occ of + Just name -> Succeeded name + Nothing -> Failed (MissingKnownKey3 occ) } lookup_known_occ (KES_InScope { ke_rdr_env = rdr_env }) occ = case lookupKnownGRE rdr_env occ of ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -1006,7 +1006,7 @@ applyDefaultingRules :: WantedConstraints -> TcS Bool -- See Note [How type-class constraints are defaulted] applyDefaultingRules wanteds - | isEmptyWC wanteds + | isSolvedWC wanteds -- not isEmptyWC, see (SCS5) in Note [Shortcut solving] = return False | otherwise = do { (default_env, extended_rules) <- getDefaultInfo ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -671,6 +671,10 @@ Some wrinkles: don't want to reject short-cut solving just because we have some leftover /solved/ implications. #26805 was a case in point. +(SCS5) Similarly to (SCS4), `applyDefaultingRules` should use `isSolvedWC` not + `isEmptyWC`. This avoids unnecessarily trying defaulting rules on solved + constraints. + Note [Shortcut solving: incoherence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This optimization relies on coherence of dictionaries to be correct. When we ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -83,7 +83,6 @@ import GHC.Driver.DynFlags import GHC.Builtin( isUnboundName ) import GHC.Builtin.KnownKeys import GHC.Builtin.WiredIn.Types -import GHC.Builtin.Modules ( eSSENTIALS_NAME ) import GHC.Runtime.Context @@ -116,7 +115,6 @@ import GHC.Unit.Home import GHC.Unit.Home.Graph import GHC.Unit.Home.ModInfo import GHC.Unit.External -import GHC.Unit.Finder import GHC.Utils.Outputable import GHC.Utils.Panic @@ -139,7 +137,6 @@ import GHC.Types.Id import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name.Reader import GHC.Types.TyThing -import GHC.Types.PkgQual import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt @@ -1119,9 +1116,7 @@ tcGetDefaultTys :: TcM (DefaultEnv, -- Default classes and types Bool) -- True <=> Use extended defaulting rules tcGetDefaultTys = do { dflags <- getDynFlags - ; hsc_env <- getTopEnv ; let ovl_strings = xopt LangExt.OverloadedStrings dflags - rebindable_kn = gopt Opt_RebindableKnownNames dflags extended_defaults = xopt LangExt.ExtendedDefaultRules dflags -- See also #1974 builtinDefaults cls tys = ClassDefaults{ cd_class = cls @@ -1133,17 +1128,11 @@ tcGetDefaultTys ; user_defaults <- getDeclaredDefaultTys -- User-supplied defaults ; this_module <- tcg_mod <$> getGblEnv ; let this_unit = moduleUnit this_module - ; found_essentials <- liftIO $ findImportedModule hsc_env eSSENTIALS_NAME NoPkgQual - ; case (found_essentials, rebindable_kn) of - (NotFound{}, False) -> -- See Wrinkle (KN5) in Note [Overview of known entities] - -- If GHC.Essentials isn't available at all when -fno-rebindable-known-names - -- don't add the built-in defaulting, bc e.g. Num is a known-entity. - return (user_defaults, extended_defaults) - _ | this_unit == ghcInternalUnit -> - -- see Remark [No built-in defaults in ghc-internal] - -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env - return (user_defaults, extended_defaults) - _ -> do + ; if this_unit == ghcInternalUnit -- if we wanted, this needn't be about ghc-internal + -- see Remark [No built-in defaults in ghc-internal] + -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env + then return (user_defaults, extended_defaults) + else do -- Not one of the built-in units -- @default Num (Integer, Double)@, plus extensions { extDef <- if extended_defaults ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -893,6 +893,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "MissingKnownKey2" = 71344 GhcDiagnosticCode "MissingKnownKey3" = 71345 GhcDiagnosticCode "KnownKeyScopeError" = 99040 + GhcDiagnosticCode "CantFindEssentials" = 49917 -- Out of scope errors GhcDiagnosticCode "NotInScope" = 76037 ===================================== docs/users_guide/separate_compilation.rst ===================================== @@ -1665,11 +1665,15 @@ flags: :type: dynamic :category: - This flag is off by default. It is typically set when compiling modules - in ``ghc-internal`` or ``base``, and tells GHC to look for a known - entity in the current top-level scope. When the flag is un-set, GHC looks - for the module ``base:GHC.KnownKeyNames``, but this module does not exist - when compiling ``ghc-internal`` or ``base``, which is why the flag is needed. + This flag is off by default. It tells GHC to look for a known entity in + the current top-level scope. When the flag is off, GHC looks for known + entities in the exports of module ``GHC.Essentials``. + + It is typically set when compiling modules in ``ghc-internal`` or ``base``, + since ``GHC.Essentials`` does not yet exist when compiling those packages. + + GHC must assume ``GHC.Essentials`` is an implicit module dependency when + and only when ``-fno-rebindable-known-names``. .. ghc-flag:: -fdefines-known-key-names :shortdesc: This module defines a known name ===================================== testsuite/tests/cabal/T27013a/Makefile ===================================== @@ -6,16 +6,16 @@ SETUP=./Setup -v0 # Reproducer for #27013 (!15899#note_676801). # -# The `composition` package depends on neither `base` nor `ghc-internal` -# (see composition.cabal: no build-depends). It uses NoImplicitPrelude -# and defines its own `(.)`. Building it should not require GHC to load -# known-key modules from `base` such as `GHC.Essentials`. +# `composition` depends on neither base nor ghc-internal and uses no known-key +# names AT ALL. We pass -frebindable-known-names just so GHC doesn't force an +# implicit GHC.Essentials dependency (which couldn't be solved because of +# -hide-all-packages). See T27013f for the failure when the flag is omitted. T27013a: clean '$(GHC_PKG)' init tmp.d '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup $(SETUP) clean - $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=tmp.d + $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS) -frebindable-known-names' --package-db=tmp.d $(SETUP) build clean : ===================================== testsuite/tests/cabal/T27013d/Makefile ===================================== @@ -2,15 +2,18 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk -# Test that compiling Data.Composition without implicit Prelude does not -# recompile the second or third time. The `composition` package's -# Data.Composition uses NoImplicitPrelude and depends on neither base nor -# ghc-internal. In !15899, it was recompiled because of an incorrect -# "GHC.Essentials package changed". +# Test that compiling Data.Composition with -hide-all-packages and +# -XNoImplicitPrelude does not recompile the second or third time. In !15899, +# it used to recompile because of an incorrect "GHC.Essentials package changed". +# +# We pass -frebindable-known-names so GHC doesn't force an implicit +# GHC.Essentials dependency: despite this module not using known-key names, +# -hide-all-packages means we can't find GHC.Essentials when it is added as an +# implicit dependency. clean: rm -f *.o *.hi T27013d: clean - '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages - '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages - '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages + '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages -frebindable-known-names + '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages -frebindable-known-names + '$(TEST_HC)' $(TEST_HC_OPTS) Composition.hs -XNoImplicitPrelude -hide-all-packages -frebindable-known-names ===================================== testsuite/tests/driver/T27013e/T27013e.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- This module is compiled with -hide-all-packages (see all.T), so neither +-- base nor GHC.Essentials can be found. The numeric literal forces GHC to +-- look up the known-key 'fromInteger', which it tries to resolve via the +-- exports of GHC.Essentials. Since GHC.Essentials cannot be found and +-- -frebindable-known-names is not in effect, this fails. +-- +-- We want a structured, helpful error here rather than a panic; see +-- GHC.Iface.Load.loadKnownKeyOccMaps. +module T27013e where + +n = 0 ===================================== testsuite/tests/driver/T27013e/T27013e.stderr ===================================== @@ -0,0 +1,13 @@ +T27013e.hs:13:5: error: [GHC-49917] + Failed to load the known-names module ‘GHC.Essentials’ from the visible packages + while looking for known-occ name ‘fromInteger’ + Did you mean to use ‘-package base’? + + Could not load module ‘GHC.Essentials’. + It is a member of the hidden package ‘base-4.23.0.0’. + Use -v to see a list of the files searched for. + + To lookup known-names in scope rather than in GHC.Essentials, + use ‘-frebindable-known-names’, and import + the necessary known-names definitions from ‘ghc-internal’. + ===================================== testsuite/tests/driver/T27013e/all.T ===================================== @@ -0,0 +1 @@ +test('T27013e', normalise_version('base'), compile_fail, ['-hide-all-packages']) ===================================== testsuite/tests/driver/T27013f/T27013f.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- Counterpart to T27013a/T27013d (see #27013, !15899). +-- +-- Like the `composition` package, this module needs no known-key. +-- It is compiled with -hide-all-packages (see all.T) and WITHOUT +-- -frebindable-known-names (unlike T27013{a,d}). +-- +-- Under the default -fno-rebindable-known-names, GHC must assume +-- GHC.Essentials is an implicit dependency and tries to discover its +-- package, which fails because nothing provides it. We want a structured +-- error here (not a panic) that points at -frebindable-known-names as the +-- way to avoid forcing that dependency. See GHC.Iface.Load. +module T27013f where + +(.) :: (b -> c) -> (a -> b) -> a -> c +(f . g) x = f (g x) ===================================== testsuite/tests/driver/T27013f/T27013f.stderr ===================================== @@ -0,0 +1,13 @@ +<no location info>: error: [GHC-49917] + Failed to load the known-names module ‘GHC.Essentials’ from the visible packages + while trying to discover its package + Did you mean to use ‘-package base’? + + Could not load module ‘GHC.Essentials’. + It is a member of the hidden package ‘base-4.23.0.0’. + Use -v to see a list of the files searched for. + + This error was triggered while trying to discover the package of ‘GHC.Essentials’, + rather than when looking up any specific known-name. + If you want to enforce ‘GHC.Essentials’ is not added to the module graph implicitly, + you should use ‘-frebindable-known-names’ ===================================== testsuite/tests/driver/T27013f/all.T ===================================== @@ -0,0 +1 @@ +test('T27013f', normalise_version('base'), compile_fail, ['-hide-all-packages']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac878ff32e63933b1f4268c7005129… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac878ff32e63933b1f4268c7005129… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/dcoutts/issue-27105-stopTicker] FIXUP: posix ticker, fix logic when using select()
by Duncan Coutts (＠dcoutts) 12 Jun '26

12 Jun '26

Duncan Coutts pushed to branch wip/dcoutts/issue-27105-stopTicker at Glasgow Haskell Compiler / GHC Commits: 8f58e22a by Duncan Coutts at 2026-06-12T15:50:56+01:00 FIXUP: posix ticker, fix logic when using select() This is why the OSX CI was hanging, it was the only platform using select, Linux and all the BSDs were using ppoll. TODO: squash this into "posix ticker: split out ppoll/select helper functions" though actually the bug seems to be already prior to that version, so unclear how this was working. - - - - - 1 changed file: - rts/posix/Ticker.c Changes: ===================================== rts/posix/Ticker.c ===================================== @@ -317,14 +317,23 @@ static void poll_init_timeout(timeout *tv, Time t) static void poll_init_fdset(fdset *fds, int fd) { - /* select() overwrites the fdset so we must rebuild it every time. */ - FD_ZERO(&fds->selectfds); - FD_SET(fd, &fds->selectfds); + /* select() modifies the fd_set: it uses the same fd_set for reporting as + * for input. Thus we must rebuild it every time. We can optimise this + * rebuilding somewhat however if we rely on select() not modifying the + * bits that we didn't ask it to look at. So we can zero the fd_set just + * once, and then only reset the single bit for the single fd, before each + * call to selct(). + */ fds->fd = fd; + FD_ZERO(&fds->selectfds); } static int poll_no_timeout(fdset *fds) { + /* select() modifies the fd_set so we must set it every time, but we rely + * on it not touching other bits to avoid having to FD_ZERO it every time + */ + FD_SET(fds->fd, &fds->selectfds); int nfds = fds->fd+1; return select(nfds, &fds->selectfds, NULL, NULL, NULL); } @@ -332,6 +341,10 @@ static int poll_no_timeout(fdset *fds) static int poll_with_timeout(fdset *fds, timeout *tv) { struct timeval tv_tmp = *tv; // copy since select may change this value. + /* select() modifies the fd_set so we must set it every time, but we rely + * on it not touching other bits to avoid having to FD_ZERO it every time + */ + FD_SET(fds->fd, &fds->selectfds); int nfds = fds->fd+1; return select(nfds, &fds->selectfds, NULL, NULL, &tv_tmp); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f58e22a271d5d20b7c06d3bc903328… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f58e22a271d5d20b7c06d3bc903328… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/amg/castz] Minor fixes
by Adam Gundry (＠adamgundry) 12 Jun '26

12 Jun '26

Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: 29d1d7b2 by Adam Gundry at 2026-06-12T15:36:55+01:00 Minor fixes - - - - - 9 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Tc/Types/Evidence.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -63,6 +63,10 @@ module GHC.Core.Coercion ( applyForAllTy, decomposeFunCastCo, + mkSymTypedCastCo, + mkTransTypedCastCo, + typedCastCoercionKind, + -- ** Decomposition instNewTyCon_maybe, @@ -97,7 +101,8 @@ module GHC.Core.Coercion ( -- ** Free variables tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, tyCoVarsOfCastCo, - coercionSize, castCoercionSize, anyFreeVarsOfCo, + coercionSize, castCoercionSize, + anyFreeVarsOfCo, anyFreeVarsOfCastCo, -- ** Substitution CvSubstEnv, emptyCvSubstEnv, @@ -123,7 +128,7 @@ module GHC.Core.Coercion ( eqCoercion, eqCoercionX, eqCastCoercion, eqCastCoercionX, -- ** Forcing evaluation of coercions - seqCo, seqCos, seqCastCoercion, + seqCo, seqCos, seqCastCoercion, seqTypedCastCoercion, -- * Pretty-printing pprCo, pprParendCo, @@ -852,15 +857,16 @@ mkFunCoNoFTF r w arg_co res_co Pair argl_ty argr_ty = coercionKind arg_co Pair resl_ty resr_ty = coercionKind res_co --- AMG TODO: more cases here, or maybe better to have a FunCo constructor of CastCoercion? -mkFunCastCoNoFTF :: HasDebugCallStack => Role -> Mult -> Type -> CastCoercion -> Type -> CastCoercion -> CastCoercion -mkFunCastCoNoFTF _ mult _ (ZCoercion arg_ty arg_cos) _ (ZCoercion res_ty res_cos) = ZCoercion (mkFunctionType mult arg_ty res_ty) (arg_cos `unionDVarSet` res_cos) -mkFunCastCoNoFTF _ mult _ (ZCoercion arg_ty arg_cos) res_ty res_co = ZCoercion (mkFunctionType mult arg_ty (castCoercionRKind res_ty res_co)) (arg_cos `unionDVarSet` coVarsOfCastCoDSet res_co) -mkFunCastCoNoFTF _ mult arg_ty arg_co _ (ZCoercion res_ty res_cos) = ZCoercion (mkFunctionType mult (castCoercionRKind arg_ty arg_co) res_ty) (res_cos `unionDVarSet` coVarsOfCastCoDSet arg_co) -mkFunCastCoNoFTF r mult _ (CCoercion arg_co) _ (CCoercion res_co) = CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co res_co) -mkFunCastCoNoFTF _ _ _ ReflCastCo _ ReflCastCo = ReflCastCo -mkFunCastCoNoFTF r mult _ (CCoercion arg_co) res_ty ReflCastCo = CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co (mkReflCo r res_ty)) -mkFunCastCoNoFTF r mult arg_ty ReflCastCo _ (CCoercion res_co) = CCoercion (mkFunCoNoFTF r (multToCo mult) (mkReflCo r arg_ty) res_co) +-- AMG TODO: maybe better to have a FunCo constructor of CastCoercion? +mkFunCastCoNoFTF :: HasDebugCallStack => Role -> Mult -> TypedCastCoercion -> TypedCastCoercion -> CastCoercion +mkFunCastCoNoFTF r mult (TCC arg_ty0 arg_co) (TCC res_ty0 res_co) = + case (arg_co, res_co) of + (ReflCastCo, ReflCastCo) -> ReflCastCo + (ZCoercion arg_ty1 arg_cos, _) -> ZCoercion (mkFunctionType mult arg_ty1 (castCoercionRKind res_ty0 res_co)) (arg_cos `unionDVarSet` coVarsOfCastCoDSet res_co) + (_, ZCoercion res_ty1 res_cos) -> ZCoercion (mkFunctionType mult (castCoercionRKind arg_ty0 arg_co) res_ty1) (res_cos `unionDVarSet` coVarsOfCastCoDSet arg_co) + (CCoercion arg_co, CCoercion res_co) -> CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co res_co) + (CCoercion arg_co, ReflCastCo) -> CCoercion (mkFunCoNoFTF r (multToCo mult) arg_co (mkReflCo r res_ty0)) + (ReflCastCo, CCoercion res_co) -> CCoercion (mkFunCoNoFTF r (multToCo mult) (mkReflCo r arg_ty0) res_co) -- | Build a function 'Coercion' from two other 'Coercion's. That is, @@ -990,8 +996,8 @@ mkForAllCo v visL visR kind_co co = mk_forall_co v visL visR kind_co co mkForAllCastCo :: HasDebugCallStack => Role -> TyCoVar -> ForAllTyFlag -> ForAllTyFlag - -> Type -> CastCoercion -> CastCoercion -mkForAllCastCo r v visL visR ty cco = case cco of + -> TypedCastCoercion -> CastCoercion +mkForAllCastCo r v visL visR (TCC ty cco) = case cco of CCoercion co -> CCoercion (mkForAllCo v visL visR MRefl co) ZCoercion ty cos -> ZCoercion (mkTyCoForAllTy v visR ty) cos ReflCastCo | visL `eqForAllVis` visR -> ReflCastCo @@ -1224,6 +1230,9 @@ mkSymCastCo _ (CCoercion co) = CCoercion (mkSymCo co) mkSymCastCo ty (ZCoercion _ cos) = ZCoercion ty cos mkSymCastCo _ ReflCastCo = ReflCastCo +mkSymTypedCastCo :: TypedCastCoercion -> TypedCastCoercion +mkSymTypedCastCo (TCC ty co) = TCC (castCoercionRKind ty co) (mkSymCastCo ty co) + -- | mkTransCo creates a new 'Coercion' by composing the two -- given 'Coercion's transitively: (co1 ; co2) mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion @@ -2529,6 +2538,9 @@ seqCastCoercion (CCoercion co) = seqCo co seqCastCoercion (ZCoercion ty cos) = seqType ty `seq` seqDVarSet cos seqCastCoercion ReflCastCo = () +seqTypedCastCoercion :: TypedCastCoercion -> () +seqTypedCastCoercion (TCC ty co) = seqType ty `seq` seqCastCoercion co + seqCo :: Coercion -> () seqCo (Refl ty) = seqType ty seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco @@ -3022,3 +3034,10 @@ coToCastCo :: Coercion -> CastCoercion -- See #19815 for a bit of data and discussion on this point coToCastCo co | isReflCo co = ReflCastCo | otherwise = CCoercion co + + +typedCastCoercionKind :: TypedCastCoercion -> Pair Type +typedCastCoercionKind (TCC tyL co) = Pair (castCoercionLKind tyL co) (castCoercionRKind tyL co) + +mkTransTypedCastCo :: TypedCastCoercion -> TypedCastCoercion -> TypedCastCoercion +mkTransTypedCastCo (TCC ty1 co1) (TCC _ co2) = TCC ty1 (mkTransCastCo co1 co2) ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -4,7 +4,7 @@ module GHC.Core.Coercion.Opt ( optCoercion, optTransCo - , optCastCoercion + , optCastCoercion, optTransCastCo , OptCoercionOpts (..) ) where @@ -178,6 +178,18 @@ optTransCo opts in_scope co1 co2 | otherwise = co1 `mkTransCo` co2 +optTransCastCo :: HasDebugCallStack => OptCoercionOpts -> InScopeSet + -> TypedCastCoercion -> TypedCastCoercion -> TypedCastCoercion +optTransCastCo opts in_scope co1 co2 + | optCoercionEnabled opts + = case (co1, co2) of + (TCC ty (CCoercion co1'), TCC _ (CCoercion co2')) -> TCC ty (CCoercion (opt_trans in_scope co1' co2')) + (co1, TCC _ ReflCastCo) -> co1 + (TCC _ ReflCastCo, co2) -> co2 + _ -> co1 `mkTransTypedCastCo` co2 + | otherwise + = co1 `mkTransTypedCastCo` co2 + -- AMG TODO: not clear if coercionLKind or substTy is better choice here optCastCoercion :: OptCoercionOpts -> Subst -> TypedCastCoercion -> TypedCastCoercion optCastCoercion _ env (TCC tyL ReflCastCo) = TCC (substTy env tyL) ReflCastCo ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2702,7 +2702,6 @@ tryEtaReduce rec_ids bndrs body eval_sd where incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2) - -- AMG TOOD: make this pass TypedCastCoercion so we can call ok_arg more easily? go :: [Var] -- Binders, innermost first, types [a3,a2,a1] -> CoreExpr -- Of type tr -> CastCoercion -- Of type tr ~ ts @@ -2723,7 +2722,7 @@ tryEtaReduce rec_ids bndrs body eval_sd -- Float app ticks: \x -> Tick t (e x) ==> Tick t e go (b : bs) (App fun arg) co - | Just (co', ticks) <- ok_arg b arg co (exprType fun) (exprType (App fun arg)) + | Just (co', ticks) <- ok_arg b arg (TCC (exprType (App fun arg)) co) (exprType fun) = fmap (flip (foldr mkTick) ticks) $ go bs fun co' -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e @@ -2795,19 +2794,18 @@ tryEtaReduce rec_ids bndrs body eval_sd --------------- ok_arg :: Var -- Of type bndr_t -> CoreExpr -- Of type arg_t - -> CastCoercion -- Of kind (t1~t2) + -> TypedCastCoercion-- Of kind (t1~t2) -> Type -- Type (arg_t -> t1) of the function -- to which the argument is supplied - -> Type -- Type t1 of the result (AMG TODO: use TypedCastCoercion or avoid needing to pass this?) -> Maybe (CastCoercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) -- (and similarly for tyvars, coercion args) , [CoreTickish]) -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type arg_ty) co fun_ty res_ty + ok_arg bndr (Type arg_ty) co fun_ty | Just tv <- getTyVar_maybe arg_ty , bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of Just (Bndr _ vis, _) -> Just (fco, []) - where !fco = mkForAllCastCo Representational tv vis coreTyLamForAllTyFlag res_ty co + where !fco = mkForAllCastCo Representational tv vis coreTyLamForAllTyFlag co -- The lambda we are eta-reducing always has visibility -- 'coreTyLamForAllTyFlag' which may or may not match -- the visibility on the inner function (#24014) @@ -2815,24 +2813,25 @@ tryEtaReduce rec_ids bndrs body eval_sd (text "fun:" <+> ppr bndr $$ text "arg:" <+> ppr arg_ty $$ text "fun_ty:" <+> ppr fun_ty) - ok_arg bndr (Var v) co fun_ty _ + ok_arg bndr (Var v) (TCC _ co) fun_ty | bndr == v , let mult = idMult bndr , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort = Just (mkFunResCastCo Representational bndr co, []) - ok_arg bndr (Cast e co_arg) co fun_ty _ + ok_arg bndr (Cast e co_arg) co fun_ty | (ticks, Var v) <- stripTicksTop tickishFloatable e - , Just (_, fun_mult, _, res_ty) <- splitFunTy_maybe fun_ty + , Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty , bndr == v , fun_mult `eqType` idMult bndr - = Just (mkFunCastCoNoFTF Representational fun_mult (castCoercionRKind (exprType e) co_arg) (mkSymCastCo (exprType e) co_arg) res_ty co, ticks) + , let co_arg' = TCC (exprType e) co_arg + = Just (mkFunCastCoNoFTF Representational fun_mult (mkSymTypedCastCo co_arg') co, ticks) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here - ok_arg bndr (Tick t arg) co fun_ty res_ty - | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty res_ty + ok_arg bndr (Tick t arg) co fun_ty + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty = Just (co', t:ticks) - ok_arg _ _ _ _ _ = Nothing + ok_arg _ _ _ _ = Nothing {- ********************************************************************* @@ -3003,18 +3002,17 @@ pushCoValArg co old_arg_ty = funArgTy tyR pushCoercionIntoLambda - :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> Type -> CastCoercion -> Maybe (Var, CoreExpr) + :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> TypedCastCoercion -> Maybe (Var, CoreExpr) -- This implements the Push rule from the paper on coercions -- (\x. e) |> co -- ===> -- (\x'. e |> co') -pushCoercionIntoLambda in_scope x e ty co +pushCoercionIntoLambda in_scope x e co | assert (not (isTyVar x) && not (isCoVar x)) True - , let s1s2 = castCoercionLKind ty co - , let t1t2 = castCoercionRKind ty co + , Pair s1s2 t1t2 <- typedCastCoercionKind co , Just (_, _, s1, _) <- splitFunTy_maybe s1s2 , Just (_, w1, t1,_t2) <- splitFunTy_maybe t1t2 - , (co1, co2) <- decomposeFunCastCo co + , (co1, co2) <- decomposeFunCastCo (tccCastCoercion co) , typeHasFixedRuntimeRep t1 -- We can't push the coercion into the lambda if it would create -- a representation-polymorphic binder. ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1412,6 +1412,19 @@ simplCoercion env co opts = seOptCoercionOpts env subst_only = isEmptyTvSubst subst || reSimplifying env +simplCastCoercion :: SimplEnv -> InTypedCastCoercion -> SimplM OutTypedCastCoercion +simplCastCoercion env co + = seqTypedCastCoercion opt_co `seq` return opt_co + where + -- See Note [Optimising coercions] + -- NB: substCo has a short-cut when both type and coercion substs are empty + opt_co | subst_only = substTypedCastCo subst co + | otherwise = optCastCoercion opts subst co + + subst = getTCvSubst env + opts = seOptCoercionOpts env + subst_only = isEmptyTvSubst subst || reSimplifying env + {- Note [Optimising coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some programs have very big coercions and we'd like to avoid repeatedly @@ -1440,19 +1453,6 @@ re-optimising them: -} -simplCastCoercion :: SimplEnv -> InTypedCastCoercion -> SimplM OutTypedCastCoercion -simplCastCoercion env co - = do { let opt_co | reSimplifying env = substTypedCastCo subst co - | otherwise = optCastCoercion opts subst co - -- If (reSimplifying env) is True we have already simplified - -- this coercion once, and we don't want do so again; doing - -- so repeatedly risks non-linear behaviour - -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env - ; seqCastCoercion (tccCastCoercion opt_co) `seq` return opt_co } - where - subst = getTCvSubst env - opts = seOptCoercionOpts env - ----------------------------------- -- | Push a TickIt context outwards past applications and cases, as @@ -1861,7 +1861,7 @@ simplArg :: SimplEnvIS -- ^ Used only for its InScopeSet -- continuation passed to 'simplExprC' -> OutType -- ^ Type of the function applied to this arg -> StaticEnv -> CoreExpr -- ^ Expression with its static envt - -> OutCastCoercion -- Wrap this around the result + -> OutCastCoercion -- ^ Wrap this around the result -> SimplM OutExpr simplArg _ _ _ (Simplified {}) arg co = return $ mkCastCo arg co -- See Note [Avoid repeated simplification] ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -57,7 +57,6 @@ import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Core.Type as Type ( Type, extendTvSubst, extendCvSubst , substTy, getTyVar_maybe ) -import GHC.Core.TyCo.FVs ( anyFreeVarsOfCastCo ) import GHC.Core.TyCo.Ppr( pprParendType ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -29,7 +29,7 @@ import GHC.Core.Unfold.Make import GHC.Core.Make import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Core.DataCon -import GHC.Core.Coercion.Opt ( optCoercion, optCastCoercion, OptCoercionOpts (..) ) +import GHC.Core.Coercion.Opt ( optCoercion, optCastCoercion, OptCoercionOpts (..), optTransCastCo ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) import GHC.Core.Predicate( isCoVarType ) @@ -303,11 +303,11 @@ simpleOptPgm opts this_mod binds rules = ---------------------- type SimpleClo = (SimpleOptEnv, InExpr) -data SimpleContItem = ApplyToArg SimpleClo | CastIt OutType OutCastCoercion +data SimpleContItem = ApplyToArg SimpleClo | CastIt OutTypedCastCoercion instance Outputable SimpleContItem where ppr (ApplyToArg (_, arg)) = text "ARG" <+> ppr arg - ppr (CastIt _ co) = text "CAST" <+> ppr co + ppr (CastIt co) = text "CAST" <+> ppr co data SimpleOptEnv = SOE { soe_opts :: {-# UNPACK #-} !SimpleOpts @@ -473,7 +473,7 @@ simple_app env e0@(Lam {}) as0@(_:_) where (env', b') = subst_opt_bndr env b -- See Note [Eliminate casts in function position] - do_beta env e@(Lam b _) as@(CastIt ty out_co:rest) + do_beta env e@(Lam b _) as@(CastIt out_co:rest) | isNonCoVarId b -- Optimise the inner lambda to make it an 'OutExpr', which makes it -- possible to call 'pushCoercionIntoLambda' with the 'OutCoercion' 'co'. @@ -482,7 +482,7 @@ simple_app env e0@(Lam {}) as0@(_:_) -- we need to do this to avoid mixing 'InExpr' and 'OutExpr', or two -- 'InExpr' with different environments (getting this wrong caused #26588 & #26589.) , Lam out_b out_body <- simple_app env e [] - , Just (b', body') <- pushCoercionIntoLambda (soeInScope env) out_b out_body ty out_co + , Just (b', body') <- pushCoercionIntoLambda (soeInScope env) out_b out_body out_co = do_beta (soeZapSubst env) (Lam b' body') rest -- soeZapSubst: we've already optimised everything (the lambda and 'rest') by now. | otherwise @@ -542,19 +542,18 @@ simple_app env (Cast e co) as simple_app env e as = rebuild_app env (simple_opt_expr env e) as --- FIXME (cast-zapping rebase): HEAD added optTransCo to further optimise the --- combined coercion when stacking. There is no optTransCastCo yet, so for now --- we use mkTransCastCo and leave the deeper optimisation as a TODO. add_cast :: SimpleOptEnv -> InTypedCastCoercion -> [SimpleContItem] -> [SimpleContItem] -add_cast env (TCC tyL co1) as - | isReflCastCo co1' +add_cast env co1 as + | isReflCastCo (tccCastCoercion co1) = as | otherwise = case as of - CastIt _ co2:rest -> CastIt ty (co1' `mkTransCastCo` co2):rest - _ -> CastIt ty co1':as + CastIt co2:rest -> CastIt (optTransCastCo opts in_scope opt_co1 co2):rest + _ -> CastIt opt_co1:as where - TCC ty co1' = optCastCoercion (so_co_opts (soe_opts env)) (soe_subst env) (TCC tyL co1) + opts = so_co_opts (soe_opts env) + in_scope = soeInScope env + opt_co1 = optCastCoercion opts (soe_subst env) co1 rebuild_app :: HasDebugCallStack => SimpleOptEnv -> OutExpr -> [SimpleContItem] -> OutExpr @@ -563,19 +562,19 @@ rebuild_app env fun args = foldl mk_app fun args in_scope = soeInScope env mk_app out_fun = \case ApplyToArg arg -> App out_fun (simple_opt_clo in_scope arg) - CastIt _ co -> mk_cast out_fun co + CastIt co -> mk_cast out_fun co -mk_cast :: CoreExpr -> CastCoercion -> CoreExpr +mk_cast :: CoreExpr -> TypedCastCoercion -> CoreExpr -- Like GHC.Core.Utils.mkCast, but does a full reflexivity check. -- mkCast doesn't do that because the Simplifier does (in simplCast) -- But in SimpleOpt it's nice to kill those nested casts (#18112) -mk_cast (Cast e co1) co2 = mk_cast e (co1 `mkTransCastCo` co2) -mk_cast (Tick t e) co = Tick t (mk_cast e co) +mk_cast (Cast e co1) (TCC _ co2) = mk_cast e (TCC (exprType e) (co1 `mkTransCastCo` co2)) +mk_cast (Tick t e) co = Tick t (mk_cast e co) mk_cast e co - | isReflexiveCastCo (TCC (exprType e) co) + | isReflexiveCastCo co = e | otherwise - = Cast e co + = Cast e (tccCastCoercion co) {- Note [Desugaring unlifted newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1853,7 +1852,7 @@ exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co) -- this implies that x is not in scope in gamma (makes this code simpler) , not (isTyVar x) && not (isCoVar x) , assert (not $ x `elemVarSet` tyCoVarsOfCastCo co) True - , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e (exprType casted_e) co + , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e (TCC (exprType casted_e) co) , let res = Just (x',e',ts) = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) res ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -205,11 +205,6 @@ in GHC.Tc.Solver. Yuk. This is not pretty. * * ********************************************************************* -} -tyCoVarsOfCastCo :: CastCoercion -> TyCoVarSet -tyCoVarsOfCastCo (CCoercion co) = coVarsOfCo co -tyCoVarsOfCastCo (ZCoercion ty cos) = tyCoVarsOfType ty `unionVarSet` dVarSetToVarSet cos -tyCoVarsOfCastCo ReflCastCo = emptyVarSet - tyCoVarsOfType :: Type -> TyCoVarSet -- The "deep" TyCoVars of the the type tyCoVarsOfType ty = runTyCoVars (deepTypeFV ty) @@ -227,6 +222,9 @@ tyCoVarsOfCo :: Coercion -> TyCoVarSet -- See Note [Computing deep free variables] tyCoVarsOfCo co = runTyCoVars (deepCoFV co) +tyCoVarsOfCastCo :: CastCoercion -> TyCoVarSet +tyCoVarsOfCastCo co = runTyCoVars (deepCastCoFV co) + tyCoVarsOfMCo :: MCoercion -> TyCoVarSet tyCoVarsOfMCo MRefl = emptyVarSet tyCoVarsOfMCo (MCo co) = tyCoVarsOfCo co @@ -264,7 +262,8 @@ deepTypeFV :: Type -> TyCoFV deepTypesFV :: [Type] -> TyCoFV deepCoFV :: Coercion -> TyCoFV deepCosFV :: [Coercion] -> TyCoFV -(deepTypeFV, deepTypesFV, deepCoFV, deepCosFV, _) = foldTyCo deepTcvFolder +deepCastCoFV :: CastCoercion -> TyCoFV +(deepTypeFV, deepTypesFV, deepCoFV, deepCosFV, deepCastCoFV) = foldTyCo deepTcvFolder deepTcvFolder :: TyCoFolder TyCoFV -- It's important that we use a one-shot EndoOS, to ensure that all @@ -908,10 +907,8 @@ anyFreeVarsOfCo check_fv co = DM.getAny (runFVTop (f co)) where (_, _, f, _, _) = foldTyCo (afvFolder check_fv) anyFreeVarsOfCastCo :: (TyCoVar -> Bool) -> CastCoercion -> Bool -anyFreeVarsOfCastCo check_fv (CCoercion co) = anyFreeVarsOfCo check_fv co -anyFreeVarsOfCastCo check_fv (ZCoercion ty cvs) = - anyFreeVarsOfType check_fv ty || anyDVarSet check_fv cvs -anyFreeVarsOfCastCo _ ReflCastCo = False +anyFreeVarsOfCastCo check_fv co = DM.getAny (runFVTop (f co)) + where (_, _, _, _, f) = foldTyCo (afvFolder check_fv) noFreeVarsOfType :: Type -> Bool noFreeVarsOfType ty = not $ DM.getAny (runFVTop (f ty)) ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -1058,6 +1058,9 @@ instance Outputable Coercion where instance Outputable CastCoercion where ppr = pprCastCo +instance Outputable TypedCastCoercion where + ppr (TCC ty co) = text "TCC" <> parens (ppr ty <> text "," <+> ppr co) + instance Outputable CoSel where ppr (SelTyCon n r) = text "Tc" <> parens (int n <> comma <> pprOneCharRole r) ppr SelForAll = text "All" ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -636,7 +636,7 @@ optSubTypeHsWrapper wrap not_in v (WpCompose w1 w2) = not_in v w1 && not_in v w2 not_in v (WpEvApp (EvExpr e)) = not (v `elemVarSet` exprFreeVars e) not_in v (WpEvApp (EvCastExpr e co ty)) = not (v `elemVarSet` exprFreeVars e) - && not_in_cast_co v co + && not (anyFreeVarsOfCastCo (== v) co) && not (anyFreeVarsOfType (== v) ty) not_in _ (WpEvApp (EvTypeable {})) = False -- Giving up; conservative not_in _ (WpEvApp (EvFun {})) = False -- Giving up; conservative @@ -644,13 +644,6 @@ optSubTypeHsWrapper wrap not_in _ (WpEvLam {}) = False -- Ditto not_in _ (WpLet {}) = False -- Ditto - not_in_cast_co :: TyVar -> CastCoercion -> Bool - not_in_cast_co v = \case - CCoercion co -> not (anyFreeVarsOfCo (== v) co) - ZCoercion ty cvs -> not (anyFreeVarsOfType (== v) ty) - && not (v `elemDVarSet` cvs) - ReflCastCo -> True - not_in_submult :: TyVar -> SubMultCo -> Bool not_in_submult v = \case EqMultCo co -> not (anyFreeVarsOfCo (== v) co) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29d1d7b24d49795cb561066c4954255… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29d1d7b24d49795cb561066c4954255… You're receiving this email because of your account on gitlab.haskell.org.

1 0