August 2026 - ghc-commits

[Git][ghc/ghc] Pushed new branch wip/T27737
by Simon Peyton Jones (＠simonpj) 26 Aug '26

26 Aug '26

Simon Peyton Jones pushed new branch wip/T27737 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T27737 You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/uic-reuse] Reuse the UnitIndexCache after initialising multiple home units
by Hannes Siebenhandl (＠fendor) 26 Aug '26

26 Aug '26

Hannes Siebenhandl pushed to branch wip/fendor/uic-reuse at Glasgow Haskell Compiler / GHC Commits: ec0faf75 by fendor at 2026-08-26T17:20:38+02:00 Reuse the UnitIndexCache after initialising multiple home units - - - - - 2 changed files: - changelog.d/unit-index - compiler/GHC/Driver/Session/Units.hs Changes: ===================================== changelog.d/unit-index ===================================== @@ -1,7 +1,7 @@ section: compiler synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units -issues: #27500 #26423 -mrs: !16115 +issues: #27500 #26423 #27748 +mrs: !16115 !16598 description: { The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s. ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -145,8 +145,15 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do checkUnitCycles initial_dflags home_unit_graph let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph - unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)) - let final_hsc_env = hsc_env { hsc_unit_env = unitEnv } + newUnitEnv <- do + env <- liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) + -- We need to reuse the 'UnitIndexCache' as we used it above in 'initUnits'. + -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] why this must be shared. + pure $ assertUnitEnvInvariant $ env + { ue_uic = hscUIC hsc_env + } + + let final_hsc_env = hsc_env { hsc_unit_env = newUnitEnv } GHC.setSession final_hsc_env View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec0faf753d2093f99f9f899de175097… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec0faf753d2093f99f9f899de175097… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/27514] 3 commits: Driver: structured concurrent worker abstraction
by sheaf (＠sheaf) 26 Aug '26

26 Aug '26

sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: 0829b0a9 by sheaf at 2026-08-26T17:09:17+02:00 Driver: structured concurrent worker abstraction This commits introduces a structured concurrency framework in the style of the 'ki' library: a collection of threads within a scope. We implement two kind of concurrent workers on top of this framework: - Independent workers cannot wait for one another at all. The only scheduling operation is to wait for quiescence. - Coordinating workers declare an STM readiness condition (waiting on other workers to complete) which gates their start. See Note [Deterministic concurrent workers] in GHC.Driver.Concurrency. This commit ports upsweep to this new framework, with downsweep being left as subsequent work. Further changes along the way: - Refactoring of how concurrency is acquired to avoid the footgun of trying to use a no-op 'AbstractSem' as a lock in the serial case. - The "re-run with -j1" logic for semaphore opening errors no longer triggers on late semaphore failures (part-way through a lengthy computation). - Logger threads are properly cleaned up on exception, with each concurrent worker's log queue and local TmpFs properly bracketed. - The 'GhcMessage -> AnyGhcDiagnostic' and 'Maybe Messager' arguments of 'depanalE', 'depanalPartial' and 'downsweep', which were all dead in practice, have been dropped. - - - - - 9bcd3345 by sheaf at 2026-08-26T17:09:17+02:00 Rule-based deterministic concurrent downsweep This commit rewrites downsweep as a single query-answering rule (see 'DownsweepRule') that can be executed by concurrent worker threads. The design allows every expensive operation (preprocessing files with CPP, parsing headers, reading interfaces) to be performed concurrently according to the -j<N>/-jsem flags. See Note [Rules-based downsweep] in GHC.Driver.Downsweep. To achieve this, the finder cache was slightly restructured in order to account for modules whose source files are directly specified as targets; see the new Note [Known home modules] in GHC.Unit.Finder.Types. This allowed us to remove 'addModuleToFinder', 'addHomeModuleToFinder' and a few brittle hacks (e.g. in Backpack). Fixes #27514 - - - - - d90b69ba by sheaf at 2026-08-26T17:09:18+02:00 Separate Home/External finder caches - - - - - 49 changed files: - + changelog.d/parallel-downsweep - compiler/GHC.hs - compiler/GHC/Builtin.hs - + compiler/GHC/Data/Dependent.hs - compiler/GHC/Driver/Backpack.hs - + compiler/GHC/Driver/Concurrency.hs - + compiler/GHC/Driver/Config/Concurrency.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Runtime/Interpreter/JS.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/UnresolvedImport.hs - compiler/GHC/Unit/Finder.hs - + compiler/GHC/Unit/Finder/Cache.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - + compiler/GHC/Utils/Concurrent/Scope.hs - compiler/GHC/Utils/TmpFs.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/T27461/Makefile - + testsuite/tests/driver/T27461/T27461c.stderr - testsuite/tests/driver/T27461/all.T - + testsuite/tests/driver/T27461/src/Wrong.hs - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/splice-imports/SI35.hs - utils/check-ppr/Main.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3cfc628fecbd4f3ac569ce37769c0d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3cfc628fecbd4f3ac569ce37769c0d… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/ghc-ghci-mhu-27640] 3 commits: Add Data.RealFloat and Infinity/NegInfinity/NaN pattern synonyms (#26961)
by Hannes Siebenhandl (＠fendor) 26 Aug '26

26 Aug '26

Hannes Siebenhandl pushed to branch wip/fendor/ghc-ghci-mhu-27640 at Glasgow Haskell Compiler / GHC Commits: b5d29ab8 by Brandon Chinn at 2026-08-25T18:42:08-04:00 Add Data.RealFloat and Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - e60eb3bc by Andreas Klebinger at 2026-08-25T18:42:59-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - 987ac4fc by fendor at 2026-08-26T17:06:05+02:00 GHCi: Fix order of `PackageDBFlag`s for interactive home unit `PackageDBFlag`s are stored in reverse order of cli specification. When sorting the `PackageDBFlag`s by longest common prefix, we need thus to reverse the package db stacks before calculating the prefix. We make sure to reverse the package db stack for the interactive home unit to uphold that later specified package dbs overwrite earlier ones. Resolved and adds regression test for #27640 - - - - - 21 changed files: - changelog.d/T27202 - ghc/GHCi/UI.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/Data/RealFloat.hs - rts/linker/elf_reloc_riscv64.c - + testsuite/tests/ghci/prog-mhu007/Makefile - + testsuite/tests/ghci/prog-mhu007/a/A.hs - + testsuite/tests/ghci/prog-mhu007/all.T - + testsuite/tests/ghci/prog-mhu007/b/B.hs - + testsuite/tests/ghci/prog-mhu007/prog-mhu007.script - + testsuite/tests/ghci/prog-mhu007/prog-mhu007.stdout - + testsuite/tests/ghci/prog-mhu007/testpkg-bar/Bar.hs - + testsuite/tests/ghci/prog-mhu007/testpkg-bar/testpkg-bar.pkg - + testsuite/tests/ghci/prog-mhu007/testpkg-foo/Foo.hs - + testsuite/tests/ghci/prog-mhu007/testpkg-foo/testpkg-foo.pkg - + testsuite/tests/ghci/prog-mhu007/unitA - + testsuite/tests/ghci/prog-mhu007/unitB - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 Changes: ===================================== changelog.d/T27202 ===================================== @@ -1,7 +1,7 @@ section: ghci synopsis: Fix regression to honour module targets in nested directories into GHCi after startup. -issues: #27202 -mrs: !15980 +issues: #27202 #27640 +mrs: !15980 !16591 description: { Fix a regression that made it impossible to import modules using `:load <Mod>` and `:add <Mod>` after GHCi startup. ===================================== ghc/GHCi/UI.hs ===================================== @@ -763,7 +763,7 @@ installInteractiveHomeUnits dflags = do -- However, in the case of multiple home units, initialised via @ghci -unit ... -unit ...@, there -- are not @-package-db@ arguments in the base 'DynFlags'... -- To fix this, we look at the home units and merge their package dbs stacks. - -- We assume, that many package db stacks look almost identical, and only differ in view elements. + -- We assume, that many package db stacks look almost identical, and only differ in few unit databases. -- Thus, we try to extract a common package db stack (i.e., longest common prefix), and then concat -- the rest of the package db stacks. At last, we add the two result package db stacks. -- This should work reliably with cabal and stack, but it is hacky. @@ -864,8 +864,14 @@ installInteractiveHomeUnits dflags = do pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag] - concatPackageDbStacksUsingLongestCommonPrefix stacks = + concatPackageDbStacksUsingLongestCommonPrefix stacks' = let + -- Package DB stacks are accumulated from the cli right to left. + -- E.g., @-clear-package-db -global-package-db@ is stored as + -- @[PackageDB GlobalPkgDb, ClearPackageDBs]@. + -- Hence, we reverse the stacks, before computing the longest common prefix, + -- otherwise the prefix won't match at all. + stacks = map List.reverse stacks' -- O (m * n) -- m ... Number of PackageDBFlag stacks -- n ... Size of the stacks @@ -873,8 +879,21 @@ installInteractiveHomeUnits dflags = do map List.head . List.takeWhile ((List.all . (==) . List.head) <*> List.tail) . List.transpose prefix = longestCommonPrefix stacks + + -- We reverse each individual stack segment to maintain the relative order within in a package + -- db stack. + -- There should be no 'ClearPackageDBs' in here, otherwise we are going to overwrite + -- the longest common prefix stacks. + -- + -- @nubOrd@ can silently change precedence of package db stack merging. + -- This is not trivially avoidable right now, since multiple home units could simply + -- have package db stacks that cannot be unified. + unmergeableStack = + nubOrd (concatMap (List.reverse . List.drop (length prefix)) stacks) in - prefix ++ nubOrd (concatMap (List.drop (length prefix)) stacks) + -- We reverse the final common package db stack again to match the expectation of 'packageDBFlags' that they are + -- stord in reverse order. + unmergeableStack ++ reverse prefix reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do ===================================== libraries/base/base.cabal.in ===================================== @@ -117,6 +117,7 @@ Library , Data.Monoid , Data.Ord , Data.Proxy + , Data.RealFloat , Data.STRef , Data.STRef.Strict , Data.String ===================================== libraries/base/changelog.md ===================================== @@ -9,6 +9,8 @@ * Introduce `Data.Double` and `Data.Float` modules. ([CLC proposal #378](https://github.com/haskell/core-libraries-committee/issues/378)) * Change `Generically a`'s `Monoid` definition to require a `Semigroup` constraint, and define its `mconcat` using `(<>)` from that constraint. ([CLC proposal #413](https://github.com/haskell/core-libraries-committee/issues/413)) * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428)) + * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- +-- Module : Data.RealFloat +-- Copyright : (c) The University of Glasgow 2026 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries(a)haskell.org +-- Stability : stable +-- Portability : portable +-- + +module Data.RealFloat ( + RealFloat (..), + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, +) where + +import Data.Bool (Bool (..), (&&)) +import GHC.Internal.Data.Ord ((<), (>)) +import GHC.Internal.Float (RealFloat (..)) +import GHC.Internal.Real ((/)) +#if __GLASGOW_HASKELL__ >= 1001 +import qualified GHC.Essentials as Rebindable +#endif + +pattern Infinity :: (RealFloat a) => a +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Provided for convenience. Could also use the following instead: +-- * Pattern matching: @(negate -> Infinity)@ +-- * Expressions: @-Infinity@ +pattern NegInfinity :: (RealFloat a) => a +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +-- | A pattern synonym for NaN values. +-- +-- Note: Per IEEE 754, NaN is never equal to itself, thus these two snippets +-- have different behavior: +-- +-- @ +-- -- foo1 NaN == "a" +-- foo1 NaN = "a" +-- foo1 _ = "b" +-- +-- -- foo2 NaN == "b" +-- foo2 x = if x == NaN then "a" else "b" +-- @ +pattern NaN :: (RealFloat a) => a +pattern NaN <- (isNaN -> True) where NaN = 0/0 ===================================== rts/linker/elf_reloc_riscv64.c ===================================== @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) { /* The main object code */ void *codeBegin = oc->image + oc->misalignment; - __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize)); + __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize)); /* Jump Islands */ __builtin___clear_cache((void *)oc->symbol_extras, ===================================== testsuite/tests/ghci/prog-mhu007/Makefile ===================================== @@ -0,0 +1,33 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +PKGCONF_FOO=local-foo.package.conf +PKGCONF_BAR=local-bar.package.conf +LOCAL_GHC_PKG_FOO = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_FOO) +LOCAL_GHC_PKG_BAR = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_BAR) + +# Finds both packages in different unit databases +.PHONY: prog-mhu007 +prog-mhu007: + cd testpkg-foo && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-foo-0.1.0.0 -this-unit-id testpkg-foo-0.1.0.0-XXX \ + -i. Foo + cd testpkg-bar && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-bar-0.1.0.0 -this-unit-id testpkg-bar-0.1.0.0-XXX \ + -i. Bar + + $(LOCAL_GHC_PKG_FOO) init $(PKGCONF_FOO) 2>/dev/null + $(LOCAL_GHC_PKG_FOO) register --force testpkg-foo/testpkg-foo.pkg 2>/dev/null + $(LOCAL_GHC_PKG_FOO) hide testpkg-foo + $(LOCAL_GHC_PKG_FOO) list + + $(LOCAL_GHC_PKG_BAR) init $(PKGCONF_BAR) 2>/dev/null + $(LOCAL_GHC_PKG_BAR) register --force testpkg-bar/testpkg-bar.pkg 2>/dev/null + $(LOCAL_GHC_PKG_BAR) hide testpkg-bar + $(LOCAL_GHC_PKG_BAR) list + + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db -fno-code -unit @unitA -unit @unitB < prog-mhu007.script ===================================== testsuite/tests/ghci/prog-mhu007/a/A.hs ===================================== @@ -0,0 +1,3 @@ +module A where + +import Bar ===================================== testsuite/tests/ghci/prog-mhu007/all.T ===================================== @@ -0,0 +1,8 @@ + +proj_files = extra_files(['a/', 'b/', 'unitA', 'unitB', 'testpkg-bar/', 'testpkg-foo/']) + +test('prog-mhu007', + [proj_files, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + makefile_test, ['prog-mhu007']) ===================================== testsuite/tests/ghci/prog-mhu007/b/B.hs ===================================== @@ -0,0 +1,3 @@ +module B where + +import Foo ===================================== testsuite/tests/ghci/prog-mhu007/prog-mhu007.script ===================================== @@ -0,0 +1,5 @@ +:m + A B +"Loaded A and B" +import Foo +import Bar +"Loaded dependencies Foo and Bar" ===================================== testsuite/tests/ghci/prog-mhu007/prog-mhu007.stdout ===================================== @@ -0,0 +1,10 @@ +Reading package info from "testpkg-foo/testpkg-foo.pkg" ... done. +local-foo.package.conf + (testpkg-foo-0.1.0.0) + +Reading package info from "testpkg-bar/testpkg-bar.pkg" ... done. +local-bar.package.conf + (testpkg-bar-0.1.0.0) + +"Loaded A and B" +"Loaded dependencies Foo and Bar" ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-bar/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-bar/testpkg-bar.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg-bar +version: 0.1.0.0 +id: testpkg-bar-0.1.0.0-XXX +key: testpkg-bar-0.1.0.0-XXX +exposed: True +exposed-modules: Bar +hidden-modules: +import-dirs: ${pkgroot}/testpkg-bar/dist-testpkg-bar-0.1.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-foo/Foo.hs ===================================== @@ -0,0 +1 @@ +module Foo where ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-foo/testpkg-foo.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg-foo +version: 0.1.0.0 +id: testpkg-foo-0.1.0.0-XXX +key: testpkg-foo-0.1.0.0-XXX +exposed: True +exposed-modules: Foo +hidden-modules: +import-dirs: ${pkgroot}/testpkg-foo/dist-testpkg-foo-0.1.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog-mhu007/unitA ===================================== @@ -0,0 +1,11 @@ +-i +-ia/ +A +-this-unit-id a-0.0.0 +-this-package-name a +-clear-package-db +-global-package-db +-no-user-package-db +-package-db local-bar.package.conf +-package base +-package-id testpkg-bar-0.1.0.0-XXX ===================================== testsuite/tests/ghci/prog-mhu007/unitB ===================================== @@ -0,0 +1,11 @@ +-i +-ib/ +B +-this-unit-id b-0.0.0 +-this-package-name b +-clear-package-db +-global-package-db +-no-user-package-db +-package-db local-foo.package.conf +-package base +-package-id testpkg-foo-0.1.0.0-XXX ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1626,6 +1626,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1626,6 +1626,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1626,6 +1626,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b304c203d3f30dc9c8c9fa381a1268… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b304c203d3f30dc9c8c9fa381a1268… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/ci-stages] fixup! ci: build and test stage
by Magnus (＠MangoIV) 26 Aug '26

26 Aug '26

Magnus pushed to branch wip/mangoiv/ci-stages at Glasgow Haskell Compiler / GHC Commits: 66254fae by mangoiv at 2026-08-26T16:58:54+02:00 fixup! ci: build and test stage - - - - - 3 changed files: - hadrian/src/Base.hs - hadrian/src/Builder.hs - hadrian/src/Hadrian/Package.hs Changes: ===================================== hadrian/src/Base.hs ===================================== @@ -22,6 +22,7 @@ module Base ( module Development.Shake.Util, Vec(..), (&%>), + exe, -- * Basic data types module Hadrian.Package, @@ -56,8 +57,9 @@ import Development.Shake hiding (unit, (&%>), Normal) import Development.Shake hiding (unit, (&%>), (*>), Normal) #endif import qualified Development.Shake as Shake +import qualified Development.Shake.FilePath as Shake import Development.Shake.Classes -import Development.Shake.FilePath +import Development.Shake.FilePath hiding (exe) import Development.Shake.Util import Hadrian.Oracles.DirectoryContents import Hadrian.Utilities @@ -68,6 +70,18 @@ import GHC.Stack ( HasCallStack ) import Stage import Way +isWasm :: Bool +isWasm = +#if defined(wasm32_HOST_ARCH) + True +#else + False +#endif + +exe :: FilePath +exe | isWasm = "wasm" + | otherwise = Shake.exe + -- | Hadrian lives in the 'hadrianPath' directory of the GHC tree. hadrianPath :: FilePath hadrianPath = "hadrian" ===================================== hadrian/src/Builder.hs ===================================== @@ -15,7 +15,6 @@ import Control.Exception.Extra (Partial) import qualified Data.ByteString.Lazy.Char8 as BSL import Development.Shake.Classes import Development.Shake.Command -import Development.Shake.FilePath import GHC.Generics import GHC.Platform.ArchOS (ArchOS(..), Arch(..), OS(..)) import qualified Hadrian.Builder as H ===================================== hadrian/src/Hadrian/Package.hs ===================================== @@ -23,7 +23,7 @@ module Hadrian.Package ( ) where import Development.Shake.Classes -import Development.Shake.FilePath +import Development.Shake.FilePath ((<.>)) import GHC.Generics import Hadrian.Utilities View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66254fae94590a7c9d45e88fb42423e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66254fae94590a7c9d45e88fb42423e… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/27514] 3 commits: Driver: structured concurrent worker abstraction
by sheaf (＠sheaf) 26 Aug '26

26 Aug '26

sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: c2bf457c by sheaf at 2026-08-26T16:48:48+02:00 Driver: structured concurrent worker abstraction This commits introduces a structured concurrency framework in the style of the 'ki' library: a collection of threads within a scope. We implement two kind of concurrent workers on top of this framework: - Independent workers cannot wait for one another at all. The only scheduling operation is to wait for quiescence. - Coordinating workers declare an STM readiness condition (waiting on other workers to complete) which gates their start. See Note [Deterministic concurrent workers] in GHC.Driver.Concurrency. This commit ports upsweep to this new framework, with downsweep being left as subsequent work. Further changes along the way: - Refactoring of how concurrency is acquired to avoid the footgun of trying to use a no-op 'AbstractSem' as a lock in the serial case. - The "re-run with -j1" logic for semaphore opening errors no longer triggers on late semaphore failures (part-way through a lengthy computation). - Logger threads are properly cleaned up on exception, with each concurrent worker's log queue and local TmpFs properly bracketed. - The 'GhcMessage -> AnyGhcDiagnostic' and 'Maybe Messager' arguments of 'depanalE', 'depanalPartial' and 'downsweep', which were all dead in practice, have been dropped. - - - - - 639a0cc5 by sheaf at 2026-08-26T16:48:48+02:00 Rule-based deterministic concurrent downsweep This commit rewrites downsweep as a single query-answering rule (see 'DownsweepRule') that can be executed by concurrent worker threads. The design allows every expensive operation (preprocessing files with CPP, parsing headers, reading interfaces) to be performed concurrently according to the -j<N>/-jsem flags. See Note [Rules-based downsweep] in GHC.Driver.Downsweep. To achieve this, the finder cache was slightly restructured in order to account for modules whose source files are directly specified as targets; see the new Note [Known home modules] in GHC.Unit.Finder.Types. This allowed us to remove 'addModuleToFinder', 'addHomeModuleToFinder' and a few brittle hacks (e.g. in Backpack). Fixes #27514 - - - - - 3cfc628f by sheaf at 2026-08-26T16:48:49+02:00 Separate Home/External finder caches - - - - - 49 changed files: - + changelog.d/parallel-downsweep - compiler/GHC.hs - compiler/GHC/Builtin.hs - + compiler/GHC/Data/Dependent.hs - compiler/GHC/Driver/Backpack.hs - + compiler/GHC/Driver/Concurrency.hs - + compiler/GHC/Driver/Config/Concurrency.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Runtime/Interpreter/JS.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/UnresolvedImport.hs - compiler/GHC/Unit/Finder.hs - + compiler/GHC/Unit/Finder/Cache.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - + compiler/GHC/Utils/Concurrent/Scope.hs - compiler/GHC/Utils/TmpFs.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/T27461/Makefile - + testsuite/tests/driver/T27461/T27461c.stderr - testsuite/tests/driver/T27461/all.T - + testsuite/tests/driver/T27461/src/Wrong.hs - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/splice-imports/SI35.hs - utils/check-ppr/Main.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c42975cd756edadbdd9278c9d02259… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c42975cd756edadbdd9278c9d02259… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/27514] 3 commits: Driver: structured concurrent worker abstraction
by sheaf (＠sheaf) 26 Aug '26

26 Aug '26

sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: 21c680bf by sheaf at 2026-08-26T16:39:29+02:00 Driver: structured concurrent worker abstraction This commits introduces a structured concurrency framework in the style of the 'ki' library: a collection of threads within a scope. We implement two kind of concurrent workers on top of this framework: - Independent workers cannot wait for one another at all. The only scheduling operation is to wait for quiescence. - Coordinating workers declare an STM readiness condition (waiting on other workers to complete) which gates their start. See Note [Deterministic concurrent workers] in GHC.Driver.Concurrency. This commit ports upsweep to this new framework, with downsweep being left as subsequent work. Further changes along the way: - Refactoring of how concurrency is acquired to avoid the footgun of trying to use a no-op 'AbstractSem' as a lock in the serial case. - The "re-run with -j1" logic for semaphore opening errors no longer triggers on late semaphore failures (part-way through a lengthy computation). - Logger threads are properly cleaned up on exception, with each concurrent worker's log queue and local TmpFs properly bracketed. - The 'GhcMessage -> AnyGhcDiagnostic' and 'Maybe Messager' arguments of 'depanalE', 'depanalPartial' and 'downsweep', which were all dead in practice, have been dropped. - - - - - b39cd439 by sheaf at 2026-08-26T16:39:30+02:00 Rule-based deterministic concurrent downsweep This commit rewrites downsweep as a single query-answering rule (see 'DownsweepRule') that can be executed by concurrent worker threads. The design allows every expensive operation (preprocessing files with CPP, parsing headers, reading interfaces) to be performed concurrently according to the -j<N>/-jsem flags. See Note [Rules-based downsweep] in GHC.Driver.Downsweep. To achieve this, the finder cache was slightly restructured in order to account for modules whose source files are directly specified as targets; see the new Note [Known home modules] in GHC.Unit.Finder.Types. This allowed us to remove 'addModuleToFinder', 'addHomeModuleToFinder' and a few brittle hacks (e.g. in Backpack). Fixes #27514 - - - - - c42975cd by sheaf at 2026-08-26T16:39:30+02:00 Separate Home/External finder caches - - - - - 49 changed files: - + changelog.d/parallel-downsweep - compiler/GHC.hs - compiler/GHC/Builtin.hs - + compiler/GHC/Data/Dependent.hs - compiler/GHC/Driver/Backpack.hs - + compiler/GHC/Driver/Concurrency.hs - + compiler/GHC/Driver/Config/Concurrency.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Runtime/Interpreter/JS.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/UnresolvedImport.hs - compiler/GHC/Unit/Finder.hs - + compiler/GHC/Unit/Finder/Cache.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - + compiler/GHC/Utils/Concurrent/Scope.hs - compiler/GHC/Utils/TmpFs.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/T27461/Makefile - + testsuite/tests/driver/T27461/T27461c.stderr - testsuite/tests/driver/T27461/all.T - + testsuite/tests/driver/T27461/src/Wrong.hs - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/splice-imports/SI35.hs - utils/check-ppr/Main.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6f6fe2d090d2acf4384de378e51667… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6f6fe2d090d2acf4384de378e51667… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/27514] 3 commits: Driver: structured concurrent worker abstraction
by sheaf (＠sheaf) 26 Aug '26

26 Aug '26

sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: 57fdff77 by sheaf at 2026-08-26T16:19:39+02:00 Driver: structured concurrent worker abstraction This commits introduces a structured concurrency framework in the style of the 'ki' library: a collection of threads within a scope. We implement two kind of concurrent workers on top of this framework: - Independent workers cannot wait for one another at all. The only scheduling operation is to wait for quiescence. - Coordinating workers declare an STM readiness condition (waiting on other workers to complete) which gates their start. See Note [Deterministic concurrent workers] in GHC.Driver.Concurrency. This commit ports upsweep to this new framework, with downsweep being left as subsequent work. Further changes along the way: - Refactoring of how concurrency is acquired to avoid the footgun of trying to use a no-op 'AbstractSem' as a lock in the serial case. - The "re-run with -j1" logic for semaphore opening errors no longer triggers on late semaphore failures (part-way through a lengthy computation). - Logger threads are properly cleaned up on exception, with each concurrent worker's log queue and local TmpFs properly bracketed. - The 'GhcMessage -> AnyGhcDiagnostic' and 'Maybe Messager' arguments of 'depanalE', 'depanalPartial' and 'downsweep', which were all dead in practice, have been dropped. - - - - - 56a87ca8 by sheaf at 2026-08-26T16:19:40+02:00 Rule-based deterministic concurrent downsweep This commit rewrites downsweep as a single query-answering rule (see 'DownsweepRule') that can be executed by concurrent worker threads. The design allows every expensive operation (preprocessing files with CPP, parsing headers, reading interfaces) to be performed concurrently according to the -j<N>/-jsem flags. See Note [Rules-based downsweep] in GHC.Driver.Downsweep. To achieve this, the finder cache was slightly restructured in order to account for modules whose source files are directly specified as targets; see the new Note [Known home modules] in GHC.Unit.Finder.Types. This allowed us to remove 'addModuleToFinder', 'addHomeModuleToFinder' and a few brittle hacks (e.g. in Backpack). Fixes #27514 - - - - - 6f6fe2d0 by sheaf at 2026-08-26T16:19:40+02:00 Separate Home/External finder caches - - - - - 49 changed files: - + changelog.d/parallel-downsweep - compiler/GHC.hs - compiler/GHC/Builtin.hs - + compiler/GHC/Data/Dependent.hs - compiler/GHC/Driver/Backpack.hs - + compiler/GHC/Driver/Concurrency.hs - + compiler/GHC/Driver/Config/Concurrency.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Runtime/Interpreter/JS.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/UnresolvedImport.hs - compiler/GHC/Unit/Finder.hs - + compiler/GHC/Unit/Finder/Cache.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - + compiler/GHC/Utils/Concurrent/Scope.hs - compiler/GHC/Utils/TmpFs.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/T27461/Makefile - + testsuite/tests/driver/T27461/T27461c.stderr - testsuite/tests/driver/T27461/all.T - + testsuite/tests/driver/T27461/src/Wrong.hs - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/splice-imports/SI35.hs - utils/check-ppr/Main.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68246948ad2370cd9da4d73635c648… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68246948ad2370cd9da4d73635c648… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/apk/fam-app-test
by Andreas Klebinger (＠AndreasK) 26 Aug '26

26 Aug '26

Andreas Klebinger pushed new branch wip/apk/fam-app-test at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/apk/fam-app-test You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/homeunit-is-just] `HomeUnitEnv` should always have a concrete `HomeUnit`
by Hannes Siebenhandl (＠fendor) 26 Aug '26

26 Aug '26

Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC Commits: 400ee8a1 by fendor at 2026-08-26T15:49:16+02:00 `HomeUnitEnv` should always have a concrete `HomeUnit` The `HomeUnit` describes what kind of home unit a particular `HomeUnitEnv` is and its `UnitId`. To get a `HomeUnit`, we need to initialise the `UnitState` via `initUnits` otherwise, we can't tell whether the `HomeUnit` is a definite one, or an indefinite one, for example a backpack signature file. That's why previously we maintained a `Maybe HomeUnit`. However, a `HomeUnitEnv` always has at least a `UnitId` (accessible via `DynFlags`). We can fake a `HomeUnit` until we have actually initialised the home unit and assume it is not a backpack unit. This avoids many partial functions that should have never been partial in the first case. - - - - - 21 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main/Hsc.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Errors.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Home.hs - compiler/GHC/Unit/Home/Graph.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -678,7 +678,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do hue { homeUnitEnv_units = unit_state , homeUnitEnv_dflags = updated_dflags - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env) @@ -767,7 +767,7 @@ setProgramDynFlags_ invalidate_needed dflags = do { homeUnitEnv_units = unit_state , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = old_hpt - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph @@ -891,7 +891,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do { homeUnitEnv_units = unit_state , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = old_hpt - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } -- When changing the DynFlags, we want the changes to apply to future @@ -1684,7 +1684,7 @@ findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do let logger = hsc_logger hsc_env liftIO $ trace_if logger (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual) - let mhome_unit = hsc_home_unit_maybe hsc_env + let home_unit = hsc_home_unit hsc_env let dflags = hsc_dflags hsc_env let sec = initSourceErrorContext dflags case pkgqual of @@ -1695,7 +1695,7 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do Nothing -> liftIO $ do res <- findImportedModule hsc_env LookupUser mod_name pkgqual case res of - Found loc m | notHomeModuleMaybe mhome_unit m -> return m + Found loc m | notHomeModule home_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -470,7 +470,7 @@ addUnit u = do , ue_home_unit_graph = HUG.unitEnv_singleton (homeUnitId home_unit) - (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) (Just home_unit)) + (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) home_unit) , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env , ue_uic = ue_uic old_unit_env ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -7,7 +7,6 @@ module GHC.Driver.Env , hscUpdateFlags , hscSetFlags , hsc_home_unit - , hsc_home_unit_maybe , hsc_units , hsc_HPT , hsc_HUE @@ -122,10 +121,7 @@ runInteractiveHsc :: HscEnv -> Hsc a -> IO a runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) hsc_home_unit :: HscEnv -> HomeUnit -hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env - -hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit -hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env +hsc_home_unit = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState hsc_units = ue_homeUnitState . hsc_unit_env @@ -390,7 +386,7 @@ lookupIfaceByModuleHsc hsc_env mod = do lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod mainModIs :: HomeUnitEnv -> Module -mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) +mainModIs hue = mkHomeModule (homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) -- | Retrieve the target code interpreter -- ===================================== compiler/GHC/Driver/Main/Hsc.hs ===================================== @@ -112,7 +112,7 @@ newHscEnv top_dir dflags = do where home_unit_graph hpt = HUG.unitEnv_singleton (homeUnitId_ dflags) - (HUG.mkHomeUnitEnv emptyUnitState dflags hpt Nothing) + (HUG.mkHomeUnitEnv emptyUnitState dflags hpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing)) newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1672,7 +1672,7 @@ maybeRehydrateBefore hsc_env mni (Just mns) = do where initialise_knot_var hsc_env = liftIO $ - let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni) + let mod_name = homeModuleInstantiation (hsc_home_unit hsc_env) (moduleNodeInfoModule mni) in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv rehydrateAfter :: HscEnv ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -373,7 +373,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let unit_env = hsc_unit_env hsc_env - let home_unit = hsc_home_unit_maybe hsc_env + let home_unit = hsc_home_unit hsc_env let tmpfs = hsc_tmpfs hsc_env let tmpdir = tmpDir dflags let platform = ue_platform unit_env @@ -473,12 +473,11 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do -- These symbols are imported into the stub.c file via RtsAPI.h, and the -- way we do the import depends on whether we're currently compiling -- the base package or not. - ++ (case home_unit of - Just hu - | isHomeUnitId hu ghcInternalUnitId - , platformOS platform == OSMinGW32 - -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"] - _ -> []) + ++ (if + | isHomeUnitId home_unit ghcInternalUnitId + , platformOS platform == OSMinGW32 + -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"] + | otherwise -> []) -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -17,9 +17,9 @@ import GHC.Driver.Config.Diagnostic import GHC.Unit.Env import GHC.Unit (UnitId) +import GHC.Unit.Home (homeUnitId) import GHC.Unit.Home.PackageTable import qualified GHC.Unit.Home.Graph as HUG -import GHC.Unit.State ( emptyUnitState ) import qualified GHC.Unit.State as State import GHC.Types.SrcLoc @@ -125,23 +125,24 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags)) - (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags - let home_units = HUG.allUnits initial_home_graph + let home_units = Set.fromList $ map homeUnitId_ $ NE.toList unitDflags - home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do - let hue_flags = homeUnitEnv_dflags homeUnitEnv - dflags = homeUnitEnv_dflags homeUnitEnv - (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) home_units + home_unit_envs <- forM unitDflags $ \dflags -> do + emptyHpt <- liftIO $ emptyHomePackageTable + (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger dflags (hscUIC hsc_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants - emptyHpt <- liftIO $ emptyHomePackageTable pure $ HomeUnitEnv { homeUnitEnv_units = unit_state , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = emptyHpt - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } + + let mainUnitId = homeUnitId $ homeUnitEnv_home_unit $ NE.head home_unit_envs + let home_unit_graph = HUG.hugFromHomeUnitEnvs $ NE.toList home_unit_envs + checkUnitCycles initial_dflags home_unit_graph let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph @@ -230,16 +231,3 @@ offsetDynFlags dflags = augment_maybe (Just f) = Just (augment f) augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f | otherwise = f - - -createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) -createUnitEnvFromFlags unitDflags = do - unitEnvList <- forM unitDflags $ \dflags -> do - emptyHpt <- emptyHomePackageTable - let newInternalUnitEnv = - HUG.mkHomeUnitEnv emptyUnitState dflags emptyHpt Nothing - return (homeUnitId_ dflags, newInternalUnitEnv) - let activeUnit = fst $ NE.head unitEnvList - return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) - - ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -82,7 +82,7 @@ mkUsageInfo uc plugins fc unit_env = do file_hashes <- liftIO $ mapM getFileHash dependent_files dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs - let hu = ue_unsafeHomeUnit unit_env + let hu = ue_homeUnit unit_env -- Dependencies on object files due to TH and plugins object_usages <- liftIO $ mkObjectUsage plugins fc needed_links needed_pkgs let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env) ===================================== compiler/GHC/Iface/Errors.hs ===================================== @@ -27,20 +27,20 @@ badIfaceFile file err = vcat [text "Bad interface file:" <+> text file, nest 4 err] -cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile +cannotFindInterface :: UnitState -> HomeUnit -> Profile -> ModuleName -> InstalledFindResult -> MissingInterfaceError -cannotFindInterface us mhu p mn ifr = +cannotFindInterface us hu p mn ifr = CantFindErr us FindingInterface $ - cantFindInstalledErr us mhu p mn ifr + cantFindInstalledErr us hu p mn ifr cantFindInstalledErr :: UnitState - -> Maybe HomeUnit + -> HomeUnit -> Profile -> ModuleName -> InstalledFindResult -> CantFindInstalled -cantFindInstalledErr unit_state mhome_unit profile mod_name find_result +cantFindInstalledErr unit_state home_unit profile mod_name find_result = CantFindInstalled mod_name more_info where build_tag = waysBuildTag (profileWays profile) @@ -52,7 +52,7 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result InstalledNotFound files mb_pkg | Just pkg <- mb_pkg - , notHomeUnitId mhome_unit pkg + , not (isHomeUnitId home_unit pkg) -> not_found_in_package pkg $ fmap unsafeDecodeUtf files | null files @@ -102,7 +102,7 @@ cantFindErr _ _ mod_name (FoundMultiple mods) cantFindErr unit_env profile mod_name find_result = CantFindInstalled mod_name more_info where - mhome_unit = ue_homeUnit unit_env + home_unit = ue_homeUnit unit_env more_info = case find_result of NoPackage pkg @@ -111,12 +111,7 @@ cantFindErr unit_env profile mod_name find_result , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest } | Just pkg <- mb_pkg - , Nothing <- mhome_unit -- no home-unit - -> not_found_in_package (toUnitId pkg) files - - | Just pkg <- mb_pkg - , Just home_unit <- mhome_unit -- there is a home-unit but the - , not (isHomeUnit home_unit pkg) -- module isn't from it + , not (isHomeUnit home_unit pkg) -- module isn't from this home unit -> not_found_in_package (toUnitId pkg) files | not (null suggest) ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -774,14 +774,14 @@ loadInterface doc_str mod from -- Check whether we have the interface already ; hsc_env <- getTopEnv - ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env) + ; let home_unit = ue_homeUnit (hsc_unit_env hsc_env) ; liftIO (lookupIfaceByModule hug (eps_PIT eps) mod) >>= \case { Just iface -> return (Succeeded iface) ; -- Already loaded _ -> do { -- READ THE MODULE IN - ; read_result <- case wantHiBootFile mhome_unit eps mod from of + ; read_result <- case wantHiBootFile home_unit eps mod from of Failed err -> return (Failed err) Succeeded hi_boot_file -> do hsc_env <- getTopEnv @@ -877,7 +877,7 @@ loadInterface doc_str mod from ; warnPprTrace bad_boot "loadInterface" (ppr mod) $ updateEps_ $ \ eps -> - if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface + if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface then eps else if bad_boot -- See Note [Loading your own hi-boot file] @@ -1042,12 +1042,12 @@ dontLeakTheHUG thing_inside = do -- | Returns @True@ if a 'ModIface' comes from an external package. -- In this case, we should NOT load it into the EPS; the entities -- should instead come from the local merged signature interface. -is_external_sig :: Maybe HomeUnit -> ModIface -> Bool -is_external_sig mhome_unit iface = +is_external_sig :: HomeUnit -> ModIface -> Bool +is_external_sig home_unit iface = -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package - notHomeModuleMaybe mhome_unit (mi_module iface) + notHomeModule home_unit (mi_module iface) -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only @@ -1071,13 +1071,12 @@ computeInterface -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation)) computeInterface hsc_env doc_str hi_boot_file mod0 = do massert (not (isHoleModule mod0)) - let mhome_unit = hsc_home_unit_maybe hsc_env + let home_unit = hsc_home_unit hsc_env let find_iface m = findAndReadIface hsc_env doc_str m mod0 hi_boot_file case getModuleInstantiation mod0 of (imod, Just indef) - | Just home_unit <- mhome_unit - , isHomeUnitIndefinite home_unit -> + | isHomeUnitIndefinite home_unit -> find_iface imod >>= \case Succeeded (iface0, path) -> rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case @@ -1134,13 +1133,13 @@ moduleFreeHolesPrecise doc_str mod return (Succeeded (renameFreeHoles ifhs insts)) Failed err -> return (Failed err) -wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom +wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr MissingInterfaceError IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot -wantHiBootFile mhome_unit eps mod from +wantHiBootFile home_unit eps mod from = case from of ImportByUser usr_boot - | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod + | usr_boot == IsBoot && notHomeModule home_unit mod -> Failed (BadSourceImport mod) | otherwise -> Succeeded usr_boot @@ -1148,7 +1147,7 @@ wantHiBootFile mhome_unit eps mod from -> Succeeded NotBoot ImportBySystem - | notHomeModuleMaybe mhome_unit mod + | notHomeModule home_unit mod -> Succeeded NotBoot -- If the module to be imported is not from this package -- don't look it up in eps_is_boot, because that is keyed @@ -1222,7 +1221,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags unit_state = hsc_units hsc_env name_cache = hsc_NC hsc_env - mhome_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env @@ -1261,7 +1260,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do trace_if logger (text "...not found") return $ Failed $ cannotFindInterface unit_state - mhome_unit + home_unit profile (moduleName mod) err ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -160,22 +160,18 @@ get_link_deps opts pls maybe_normal_osuf span mods = do = HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info)) Nothing -> do - -- It's not in the HPT because we are in one shot mode, - -- so use the Finder to get a ModLocation... - case ue_homeUnit unit_env of - Nothing -> no_obj mod - Just home_unit -> do - - let fc = ldFinderCache opts - let fopts = ldFinderOpts opts - mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) - case mb_stuff of - Found loc _ -> do - from_bc <- ldLoadByteCode opts mod loc - maybe (fallback_no_bytecode home_unit mod) pure from_bc - _ -> fallback_no_bytecode home_unit mod + -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + let fc = ldFinderCache opts + let fopts = ldFinderOpts opts + mb_stuff <- findHomeModule fc fopts hu (moduleName mod) + case mb_stuff of + Found loc _ -> do + from_bc <- ldLoadByteCode opts mod loc + maybe (fallback_no_bytecode hu mod) pure from_bc + _ -> fallback_no_bytecode hu mod where - + hu = ue_homeUnit unit_env fallback_no_bytecode home_unit mod = do let fc = ldFinderCache opts let fopts = ldFinderOpts opts ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -487,7 +487,7 @@ renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual renamePkgQual unit_env mn mb_pkg = case mb_pkg of Nothing -> NoPkgQual Just pkg_fs - | Just uid <- homeUnitId <$> ue_homeUnit unit_env + | uid <- homeUnitId (ue_homeUnit unit_env) , pkg_fs == fsLit "this" -> ThisPkg uid ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -485,17 +485,15 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache let load_info mod = do -- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps. linkable <- HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case - Nothing -> + Nothing -> do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... - case ue_homeUnit unit_env of - Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod) - Just home_unit -> do - mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) - case mb_stuff of - Found loc mod -> found loc mod - _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod) + mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) + case mb_stuff of + Found loc mod -> found loc mod + _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod) where + home_unit = ue_homeUnit unit_env found loc mod = do { mb_lnk <- findObjectLinkableMaybe mod loc ; case mb_lnk of { ===================================== compiler/GHC/Tc/Utils/Backpack.hs ===================================== @@ -286,11 +286,11 @@ implicitRequirements hsc_env normal_imports forM normal_imports $ \e -> do found <- resolveImport hsc_env e case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule home_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where - mhome_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env -- | Like @implicitRequirements'@, but returns the instantiated unit the -- imported module is from, so that that instantiated unit can be processed and @@ -302,13 +302,13 @@ implicitRequirementsShallow -> IO [InstantiatedUnit] implicitRequirementsShallow hsc_env normal_imports = go [] normal_imports where - mhome_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env go acc [] = pure acc go accR (e:imports) = do found <- resolveImport hsc_env e let acc' = case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule home_unit mod -> case moduleUnit mod of HoleUnit -> panic "implicitRequirementsShallow: HoleUnit is unreachable through findImportedModule!" RealUnit _ -> accR ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -180,8 +180,8 @@ lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) lookupGlobal_maybe hsc_env name = do { -- Try local envt let mod = icInteractiveModule (hsc_IC hsc_env) - mhome_unit = hsc_home_unit_maybe hsc_env - tcg_semantic_mod = homeModuleInstantiation mhome_unit mod + home_unit = hsc_home_unit hsc_env + tcg_semantic_mod = homeModuleInstantiation home_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name then return $ Failed $ Left name ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -371,7 +371,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = ; let -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env - !mhome_unit = hsc_home_unit_maybe hsc_env + !home_unit = hsc_home_unit hsc_env !logger = hsc_logger hsc_env maybe_rn_syntax :: forall a. a -> Maybe a ; @@ -399,7 +399,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = , tcg_th_docs = th_docs_var , tcg_mod = mod - , tcg_semantic_mod = homeModuleInstantiation mhome_unit mod + , tcg_semantic_mod = homeModuleInstantiation home_unit mod , tcg_src = hsc_src , tcg_rdr_env = emptyGlobalRdrEnv , tcg_fix_env = emptyNameEnv @@ -2574,11 +2574,11 @@ initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv ; hsc_env <- getTopEnv -- bangs to avoid leaking the envs (#19356) - ; let !mhome_unit = hsc_home_unit_maybe hsc_env + ; let !home_unit = hsc_home_unit hsc_env !knot_vars = tcg_knot_vars tcg_env -- When we are instantiating a signature, -- we DEFINITELY do not want to knot tie. - is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit) + is_instantiate = isHomeUnitInstantiating home_unit if_env = IfGblEnv { if_doc = text "initIfaceTcRn" , if_rec_types = if is_instantiate ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -53,7 +53,6 @@ module GHC.Unit.Env , ue_unitHomeUnit_maybe , ue_updateHomeUnitEnv , ue_all_home_unit_ids - , ue_unsafeHomeUnit -- * HUG Re-export , HomeUnitGraph @@ -235,14 +234,13 @@ preloadUnitsInfo' unit_env ids0 = all_infos where unit_state = HUG.homeUnitEnv_units (ue_currentHomeUnitEnv unit_env) ids = ids0 ++ inst_ids - inst_ids = case ue_homeUnit unit_env of - Nothing -> [] - Just home_unit - -- An indefinite package will have insts to HOLE, - -- which is not a real package. Don't look it up. - -- Fixes #14525 - | isHomeUnitIndefinite home_unit -> [] - | otherwise -> map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) + home_unit = ue_homeUnit unit_env + inst_ids + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + | isHomeUnitIndefinite home_unit = [] + | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) pkg_map = unitInfoMap unit_state preload = preloadUnits unit_state @@ -320,20 +318,15 @@ ue_setFlags dflags env = -- Query and modify home units in HomeUnitEnv -- ------------------------------------------------------- -ue_homeUnit :: UnitEnv -> Maybe HomeUnit +ue_homeUnit :: UnitEnv -> HomeUnit ue_homeUnit = HUG.homeUnitEnv_home_unit . ue_currentHomeUnitEnv -ue_unsafeHomeUnit :: UnitEnv -> HomeUnit -ue_unsafeHomeUnit ue = case ue_homeUnit ue of - Nothing -> panic "ue_unsafeHomeUnit: No home unit" - Just h -> h - ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit ue_unitHomeUnit_maybe uid ue_env = - HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) + HUG.homeUnitEnv_home_unit <$> HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) -- ------------------------------------------------------- -- Query and modify the currently active unit ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -5,6 +5,7 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} -- | Module finder module GHC.Unit.Finder ( @@ -210,7 +211,7 @@ findImportedModule -> IO FindResult findImportedModule hsc_env scope mod pkg_qual = let fc = hsc_FC hsc_env - mb_home_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env dflags = hsc_dflags hsc_env fopts = initFinderOpts dflags providers = mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env) @@ -220,7 +221,7 @@ findImportedModule hsc_env scope mod pkg_qual = fopts (hsc_unit_env hsc_env) providers - mb_home_unit + home_unit scope mod pkg_qual @@ -230,33 +231,30 @@ findImportedModuleNoHsc -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap - -> Maybe HomeUnit + -> HomeUnit -> ModuleLookupScope -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue home_module_name_providers_map home_unit scope mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import - ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import + ThisPkg uid | homeUnitId home_unit == uid -> home_import | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) - | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts)) + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr home_unit_id $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where - mb_home_unit_id :: Maybe UnitId - mb_home_unit_id = homeUnitId <$> mb_home_unit + home_unit_id :: UnitId + home_unit_id = homeUnitId home_unit all_opts :: [(UnitId, FinderOpts)] - all_opts = case mb_home_unit_id of - Nothing -> other_fopts - Just home_unit_id -> (home_unit_id, fopts) : other_fopts + all_opts = + (home_unit_id, fopts) : other_fopts home_import :: IO FindResult - home_import = case mb_home_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ - NoPackage (panic "findImportedModule: no home-unit") + home_import = + findHomeModule fc fopts home_unit mod_name home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name @@ -266,13 +264,11 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit unqual_import :: IO FindResult unqual_import = findHomeOrRegularPackageModule fc fopts ue - home_module_name_providers_map mb_home_unit scope mod_name + home_module_name_providers_map home_unit scope mod_name unit_state :: UnitState - unit_state = case mb_home_unit_id of - Nothing -> ue_homeUnitState ue - Just home_unit_id -> HUG.homeUnitEnv_units $ - ue_findHomeUnitEnv home_unit_id ue + unit_state = HUG.homeUnitEnv_units $ + ue_findHomeUnitEnv home_unit_id ue other_fopts :: [(UnitId, FinderOpts)] other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map @@ -287,28 +283,26 @@ findPluginModuleNoHsc -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap - -> Maybe HomeUnit + -> HomeUnit -> ModuleName -> IO FindResult -findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name = +findPluginModuleNoHsc fc fopts ue home_module_name_providers_map home_unit mod_name = findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit LookupUser mod_name + home_unit LookupUser mod_name `orIfNotFound` findExposedPluginPackageModule fc fopts unit_state mod_name where unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue -findPluginModuleNoHsc fc fopts ue _ Nothing mod_name = - findExposedPluginPackageModule fc fopts (ue_homeUnitState ue) mod_name findPluginModule :: HscEnv -> ModuleName -> IO FindResult findPluginModule hsc_env mod_name = do let fc = hsc_FC hsc_env - mb_home_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env home_module_name_providers_map = mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env) findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) - (hsc_unit_env hsc_env) home_module_name_providers_map mb_home_unit mod_name + (hsc_unit_env hsc_env) home_module_name_providers_map home_unit mod_name -- ----------------------------------------------------------------------------- -- Home Module Finder Helpers @@ -380,7 +374,7 @@ findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name (uid, | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = findHomeOrRegularPackageModule fc opts ue home_module_name_providers_map - (Just $ DefiniteHomeUnit uid Nothing) + (DefiniteHomeUnit uid Nothing) scope real_mod_name | elementOfUniqSet mod_name (finder_hiddenModules opts) , LookupUser <- scope -- A system lookup is allowed to find hidden modules. @@ -397,27 +391,22 @@ findHomeModuleAmongDeps -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap - -> Maybe HomeUnit + -> HomeUnit -> ModuleLookupScope -> ModuleName -> IO FindResult -findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name = +findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map home_unit scope mod_name = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) -- Do not try to be smart and change this to `foldr orIfNotFound home_import -- (map home_pkg_import other_fopts)`, as that would not be the same. -- `home_import` is first because we need to first look within the current -- unit before looking at the other units in order. where - home_import = case mb_home_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ - NoPackage (panic "findHomeModuleAmongDeps: no home-unit") + home_import = findHomeModule fc fopts home_unit mod_name + home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name - unit_state = case homeUnitId <$> mb_home_unit of - Nothing -> ue_homeUnitState ue - Just home_unit_id -> HUG.homeUnitEnv_units $ - ue_findHomeUnitEnv home_unit_id ue + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name @@ -428,33 +417,31 @@ findHomeOrRegularPackageModule -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap - -> Maybe HomeUnit + -> HomeUnit -> ModuleLookupScope -> ModuleName -> IO FindResult -findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name = +findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map home_unit scope mod_name = findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit scope mod_name + home_unit scope mod_name `orIfNotFound` findExposedPackageModule fc fopts unit_state scope mod_name NoPkgQual where - unit_state = case homeUnitId <$> mb_home_unit of - Nothing -> ue_homeUnitState ue - Just home_unit_id -> HUG.homeUnitEnv_units $ - ue_findHomeUnitEnv home_unit_id ue + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue -- | A version of findExactModule which takes the exact parts of the HscEnv it needs -- directly. -findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult -findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do - res <- case mb_home_unit of - Just home_unit +findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModuleNoHsc fc fopts other_fopts unit_state home_unit mod is_boot = do + res <- + if | isHomeInstalledModule home_unit mod -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod) | Just home_fopts <- HUG.unitEnv_lookup_maybe (moduleUnit mod) other_fopts -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod) - _ -> findPackageModule fc unit_state fopts mod + | otherwise + -> findPackageModule fc unit_state fopts mod case (res, is_boot) of (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc)) _ -> return res @@ -470,7 +457,7 @@ findExactModule hsc_env mod is_boot = do let dflags = hsc_dflags hsc_env let fc = hsc_FC hsc_env let unit_state = hsc_units hsc_env - let home_unit = hsc_home_unit_maybe hsc_env + let home_unit = hsc_home_unit hsc_env let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot ===================================== compiler/GHC/Unit/Home.hs ===================================== @@ -18,9 +18,7 @@ module GHC.Unit.Home , isHomeUnitInstanceOf , isHomeModule , isHomeInstalledModule - , notHomeUnitId , notHomeModule - , notHomeModuleMaybe , notHomeInstalledModule , notHomeInstalledModuleMaybe -- * Helpers @@ -144,11 +142,6 @@ isHomeUnit hu u = u == homeUnitAsUnit hu isHomeUnitId :: GenHomeUnit u -> UnitId -> Bool isHomeUnitId hu uid = uid == homeUnitId hu --- | Test if the unit-id is not the home unit-id -notHomeUnitId :: Maybe (GenHomeUnit u) -> UnitId -> Bool -notHomeUnitId Nothing _ = True -notHomeUnitId (Just hu) uid = not (isHomeUnitId hu uid) - -- | Test if the home unit is an instance of the given unit-id isHomeUnitInstanceOf :: HomeUnit -> UnitId -> Bool isHomeUnitInstanceOf hu u = homeUnitInstanceOf hu == u @@ -175,10 +168,6 @@ notHomeInstalledModuleMaybe mh m = fromMaybe True $ fmap (`notHomeInstalledModul notHomeModule :: HomeUnit -> Module -> Bool notHomeModule hu m = not (isHomeModule hu m) --- | Test if a module doesn't come from the given home unit -notHomeModuleMaybe :: Maybe HomeUnit -> Module -> Bool -notHomeModuleMaybe mh m = fromMaybe True $ fmap (`notHomeModule` m) mh - ---------------------------- -- helpers ---------------------------- @@ -211,9 +200,8 @@ homeModuleNameInstantiation hu mod_name = -- the instantiating module of @r:A@ in @p[A=q[]:B]@ is @r:A@. -- the instantiating module of @p:A@ in @p@ is @p:A@. -- the instantiating module of @r:A@ in @p@ is @r:A@. -homeModuleInstantiation :: Maybe HomeUnit -> Module -> Module -homeModuleInstantiation mhu mod - | Just hu <- mhu - , isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod) +homeModuleInstantiation :: HomeUnit -> Module -> Module +homeModuleInstantiation hu mod + | isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod) | otherwise = mod ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -50,6 +50,7 @@ module GHC.Unit.Home.Graph -- * Utilities , hugSCCs , hugFromList + , hugFromHomeUnitEnvs -- ** Printing , pprHomeUnitGraph @@ -150,11 +151,11 @@ data HomeUnitEnv = HomeUnitEnv -- -- (This changes a previous invariant: changed Jan 05.) - , homeUnitEnv_home_unit :: !(Maybe HomeUnit) + , homeUnitEnv_home_unit :: !HomeUnit -- ^ Home-unit } -mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv +mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> HomeUnit -> HomeUnitEnv mkHomeUnitEnv us dflags hpt home_unit = HomeUnitEnv { homeUnitEnv_units = us , homeUnitEnv_dflags = dflags @@ -363,6 +364,9 @@ hugSCCs hug = sccs where hugFromList :: [(UnitId, HomeUnitEnv)] -> HomeUnitGraph hugFromList = UnitEnvGraph . Map.fromList +hugFromHomeUnitEnvs :: [HomeUnitEnv] -> HomeUnitGraph +hugFromHomeUnitEnvs = hugFromList . fmap (\hue -> (homeUnitId $ homeUnitEnv_home_unit hue, hue)) + pprHomeUnitGraph :: HomeUnitGraph -> IO SDoc pprHomeUnitGraph unitEnv = do docs <- mapM (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv @@ -372,6 +376,6 @@ pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> IO SDoc pprHomeUnitEnv uid env = do hptDoc <- pprHPT $ homeUnitEnv_hpt env return $ - ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" + ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" $$ nest 4 hptDoc ===================================== ghc/GHCi/UI.hs ===================================== @@ -861,7 +861,7 @@ installInteractiveHomeUnits dflags = do (unit_state,home_unit,_mconstants) <- liftIO $ initUnits logger dflags unit_index all_home_units hpt <- liftIO emptyHomePackageTable - pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) + pure (HUG.mkHomeUnitEnv unit_state dflags hpt home_unit) concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag] concatPackageDbStacksUsingLongestCommonPrefix stacks = View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/400ee8a1c8ea569ee2442328206b871… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/400ee8a1c8ea569ee2442328206b871… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0