- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/fendor/27835] Prepend in-memory unit database for backpack
by Hannes Siebenhandl (＠fendor) 01 Oct '26

01 Oct '26

Hannes Siebenhandl pushed to branch wip/fendor/27835 at Glasgow Haskell Compiler / GHC Commits: 5305cbc1 by Hannes Siebenhandl at 2026-10-01T14:42:15+02:00 Prepend in-memory unit database for backpack The packageDbFlags are stored in reverse order. Thus, prepending will ensure that the in-memory unit database is the last item on the unit database stack. Further, the in-memory unit database needs to be able to shadow units from earlier unit databases in the unit database stack. Moreover, a `-clear-package-db` would remove the in-memory database if it weren't the last item on the stack. Closes #27835 - - - - - 5 changed files: - changelog.d/unit-index - compiler/GHC/Driver/Backpack.hs - + testsuite/tests/backpack/should_compile/T27835.bkp - + testsuite/tests/backpack/should_compile/T27835.stderr - testsuite/tests/backpack/should_compile/all.T 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 #27748 -mrs: !16115 !16598 +issues: #27500 #26423 #27748 #27835 +mrs: !16115 !16598 !16748 description: { The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s. ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -441,9 +441,11 @@ addInMemoryDatabase dflags u = do } let uic = hscUIC hsc_env liftIO $ cacheExternalUnitDatabase uic newdb - -- added at the end because ordering matters + -- Ordering matters here! We prepend the new unit database, because 'packageDBFlags' + -- works like a stack, where what's on top takes precedence over what's below (same as right-to-left when given at the CLI). + -- The new db needs highest precedence to overwrite any other in-memory units that potentially occur in the dbs below it. pure dflags - { packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] + { packageDBFlags = PackageDB (PkgDbPath (unitDatabasePath newdb)) : packageDBFlags dflags } -- | Register a new virtual unit database containing a single unit ===================================== testsuite/tests/backpack/should_compile/T27835.bkp ===================================== @@ -0,0 +1,11 @@ +unit p where + module P where + p :: Int + p = 42 + +unit q where + dependency p + module Q where + import P + q :: Int + q = p + 1 ===================================== testsuite/tests/backpack/should_compile/T27835.stderr ===================================== @@ -0,0 +1,7 @@ +[1 of 2] Processing p + Instantiating p + [1 of 1] Compiling P ( p/P.hs, T27835.out/p/P.o ) +[2 of 2] Processing q + Instantiating q + [1 of 1] Including p + [1 of 1] Compiling Q ( q/Q.hs, T27835.out/q/Q.o ) ===================================== testsuite/tests/backpack/should_compile/all.T ===================================== @@ -61,3 +61,4 @@ test('T13250', normal, backpack_compile, ['']) test('T13323', normal, backpack_compile, ['']) test('T20396', normal, backpack_compile, ['']) test('T23424', [ignore_stdout, ignore_stderr], backpack_compile, ['-ddump-rn-trace -ddump-if-trace -ddump-tc-trace']) +test('T27835', normal, backpack_compile, ['-clear-package-db -global-package-db']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5305cbc104bbb820badda5b9d2653f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5305cbc104bbb820badda5b9d2653f5… 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/27836] Fix #27836, normalise unit database path in ExternalUnitDatabases
by Hannes Siebenhandl (＠fendor) 01 Oct '26

01 Oct '26

Hannes Siebenhandl pushed to branch wip/fendor/27836 at Glasgow Haskell Compiler / GHC Commits: 0f51b26f by Hannes Siebenhandl at 2026-10-01T14:40:20+02:00 Fix #27836, normalise unit database path in ExternalUnitDatabases Add a regression test, proofing that all variations: - local-unit-db/my-test.conf - ./local-unit-db/my-test.conf - ./local-unit-db/my-test.conf/ are parsed only once. - - - - - 11 changed files: - compiler/GHC/Data/OsPath.hs - compiler/GHC/Unit/External/Database.hs - + testsuite/tests/driver/T27836/A.hs - + testsuite/tests/driver/T27836/B.hs - + testsuite/tests/driver/T27836/C.hs - + testsuite/tests/driver/T27836/Makefile - + testsuite/tests/driver/T27836/T27836.stdout - + testsuite/tests/driver/T27836/all.T - + testsuite/tests/driver/T27836/unitA - + testsuite/tests/driver/T27836/unitB - + testsuite/tests/driver/T27836/unitC Changes: ===================================== compiler/GHC/Data/OsPath.hs ===================================== @@ -13,6 +13,7 @@ module GHC.Data.OsPath , (<.>) , splitSearchPath , isRelative + , normalise , dropTrailingPathSeparator , takeDirectory , isSuffixOf ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -53,9 +53,17 @@ import System.FilePath as FilePath -- ExternalUnitDatabases -- ---------------------------------------------------------------------------- +-- | A normalised 'OsPath' that we use as the key to cache 'UnitDatabase's. +-- +-- Removes trailing path separators and unit database paths starting with @./@. +newtype NormalisedUnitDbLoc = NormalisedUnitDbLoc OsPath + deriving (Eq, Ord) + -- | Caches unit databases in-memory. data ExternalUnitDatabases unit = ExternalUnitDatabases - { eud_cachedDatabases :: !(Map OsPath (UnitDatabase unit)) + { eud_cachedDatabases :: !(Map NormalisedUnitDbLoc (UnitDatabase unit)) + -- ^ The 'Map' is keyed by a normalised 'OsPath', ensuring that 'lookupExternalUnitDatabases' + -- will never get confused by a stray @./@ or trailing @/@. } emptyExternalUnitDatabases :: ExternalUnitDatabases unit @@ -67,18 +75,20 @@ emptyExternalUnitDatabases = insertExternalUnitDatabases :: UnitDatabase unit -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit insertExternalUnitDatabases unit_db eud = ExternalUnitDatabases - { eud_cachedDatabases = Map.insert (unitDatabasePath unit_db) unit_db (eud_cachedDatabases eud) + { eud_cachedDatabases = + Map.insert (normalisedUnitDatabaseKey unit_db) unit_db (eud_cachedDatabases eud) } deleteExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit deleteExternalUnitDatabases unit_db_path eud = ExternalUnitDatabases - { eud_cachedDatabases = Map.delete unit_db_path (eud_cachedDatabases eud) + { eud_cachedDatabases = + Map.delete (normalisedUnitDatabaseKeyOsPath unit_db_path) (eud_cachedDatabases eud) } lookupExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> Maybe (UnitDatabase unit) lookupExternalUnitDatabases key eud = - Map.lookup key (eud_cachedDatabases eud) + Map.lookup (normalisedUnitDatabaseKeyOsPath key) (eud_cachedDatabases eud) -- ---------------------------------------------------------------------------- -- UnitDatabase @@ -87,12 +97,38 @@ lookupExternalUnitDatabases key eud = -- | Unit database entry. data UnitDatabase unit = UnitDatabase { unitDatabasePath :: OsPath + -- ^ On-disk location of the unit database. + -- , unitDatabaseUnits :: [GenUnitInfo unit] + -- ^ Units read from the database located at 'unitDatabasePath'. + -- + -- These units have the @$pkgroot@ variable already resolved. } instance (Outputable u) => Outputable (UnitDatabase u) where ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp +normalisedUnitDatabaseKey :: UnitDatabase unit -> NormalisedUnitDbLoc +normalisedUnitDatabaseKey unit_db = normalisedUnitDatabaseKeyOsPath $ unitDatabasePath unit_db + +-- | Normalise the unit database location and drop trailing path separators. +-- +-- This ensures that two databases that point to the same location can be cached. +-- +-- We need to remove trailing slash from the 'OsPath' before calculating @$pkgroot@ (Fix #16360) +normalisedUnitDatabaseKeyOsPath :: OsPath -> NormalisedUnitDbLoc +normalisedUnitDatabaseKeyOsPath db_path = + NormalisedUnitDbLoc $ OsPath.dropTrailingPathSeparator $ OsPath.normalise db_path + +-- | Get the root location of a unit database. +-- Used to replace @$pkgroot@ variables in the 'GenericUnitInfo'. +unitDatabaseRoot :: OsPath -> OsPath +unitDatabaseRoot p = + let + NormalisedUnitDbLoc np = normalisedUnitDatabaseKeyOsPath p + in + OsPath.takeDirectory np + -- ---------------------------------------------------------------------------- -- -- Merging databases @@ -258,14 +294,12 @@ readUnitDatabase logger cfg conf_file = do "can't find a package database at " ++ show conf_file let - -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = OsPath.dropTrailingPathSeparator conf_file top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg) - pkgroot = OsPath.takeDirectory conf_file' + pkgroot = unitDatabaseRoot conf_file pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) proto_pkg_configs -- - return $ UnitDatabase conf_file' pkg_configs1 + return $ UnitDatabase conf_file pkg_configs1 where readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] readDirStyleUnitInfo conf_dir = do ===================================== testsuite/tests/driver/T27836/A.hs ===================================== @@ -0,0 +1,4 @@ +module A where + +a :: Int +a = 1 ===================================== testsuite/tests/driver/T27836/B.hs ===================================== @@ -0,0 +1,4 @@ +module B where + +b :: Int +b = 1 ===================================== testsuite/tests/driver/T27836/C.hs ===================================== @@ -0,0 +1,4 @@ +module C where + +b :: Int +b = 1 ===================================== testsuite/tests/driver/T27836/Makefile ===================================== @@ -0,0 +1,21 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T27836: + mkdir local-unit-db/ + cd local-unit-db/ && '$(GHC_PKG)' init my-test.conf + # All these unit database paths should resolve to the same location + # thus after the first time parsing the unit database, we shouldn't parse it again. + '$(TEST_HC)' $(TEST_HC_OPTS) --make \ + -unit @unitA -unit @unitB -unit @unitC \ + -v2 -fforce-recomp 2>&1 \ + | grep 'Using binary package database:' + + echo "" + echo "" + echo "All -package-db variations:" + echo "- local-unit-db/my-test.conf" + echo "- ./local-unit-db/my-test.conf" + echo "- ./local-unit-db/my-test.conf/" + echo "Must be parsed only once." ===================================== testsuite/tests/driver/T27836/T27836.stdout ===================================== @@ -0,0 +1,8 @@ +Using binary package database: local-unit-db/my-test.conf/package.cache + + +All -package-db variations: +- local-unit-db/my-test.conf +- ./local-unit-db/my-test.conf +- ./local-unit-db/my-test.conf/ +Must be parsed only once. ===================================== testsuite/tests/driver/T27836/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27836', + [ extra_files(['A.hs', 'B.hs', 'C.hs', 'unitA', 'unitB', 'unitC']), normalise_slashes + ], + makefile_test, ['T27836']) ===================================== testsuite/tests/driver/T27836/unitA ===================================== @@ -0,0 +1 @@ +-hide-all-packages -no-user-package-db -package-db local-unit-db/my-test.conf -package base -this-unit-id a-0.0.0 A ===================================== testsuite/tests/driver/T27836/unitB ===================================== @@ -0,0 +1 @@ +-hide-all-packages -no-user-package-db -package-db ./local-unit-db/my-test.conf -package base -this-unit-id b-0.0.0 B ===================================== testsuite/tests/driver/T27836/unitC ===================================== @@ -0,0 +1 @@ +-hide-all-packages -no-user-package-db -package-db ./local-unit-db/my-test.conf/ -package base -this-unit-id c-0.0.0 C View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f51b26f42c35e42035bbb46b8d0f68… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f51b26f42c35e42035bbb46b8d0f68… 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/T26543b] Rename CycleBreakerTv to GivenCycleBreakerTv [skip ci]
by Simon Peyton Jones (＠simonpj) 01 Oct '26

01 Oct '26

Simon Peyton Jones pushed to branch wip/T26543b at Glasgow Haskell Compiler / GHC Commits: 5e6c1f43 by Simon Peyton Jones at 2026-10-01T13:07:42+01:00 Rename CycleBreakerTv to GivenCycleBreakerTv [skip ci] .. and add documentation - - - - - 7 changed files: - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs Changes: ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -2584,15 +2584,15 @@ turn controls the behaviour of the workhorse: GHC.Tc.Utils.Unify.checkTyEqRhs. The details depend on whether we're working with a Given or a Wanted. -Given ------ +Note [Type equality cycles: Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We emit a new Given, [G] F a ~ cbv, equating the type family application to our new cbv. This is actually done by `break_given` in `GHC.Tc.Solver.Monad.checkTypeEq`. -Note its orientation: The type family ends up on the left; see -Note [Orienting TyFamLHS/TyFamLHS]. No special treatment for -CycleBreakerTvs is necessary. This scenario is now easily soluble, by using +Note its orientation: The type family ends up on the left; +see Note [Orienting TyFamLHS/TyFamLHS]. No special treatment for +GivenCycleBreakerTvs is necessary. This scenario is now easily soluble, by using the first Given to rewrite the Wanted, which can now be solved. (The first Given actually also rewrites the second one, giving @@ -2613,10 +2613,11 @@ to Note that * `cbv` is a fresh cycle breaker variable. -* `cbv` is a meta-tyvar, but it is completely untouchable. +* `cbv` is a meta-tyvar, of flavour GivenCycleBreakerTv, but it is + completely untouchable. * We track the cycle-breaker variables in inert_cycle_breakers in InertSet -* We eventually fill in the cycle-breakers, with `cbv := F lhs`. - No one else fills in CycleBreakerTvs! +* We eventually fill in the cycle-breakers, with `cbv := F lhs`, + via `restoreTyVarCycles`. No one else fills in GivenCycleBreakerTvs! * The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know this fill-in is ultimately going to happen. * In `inert_cycle_breakers`, we remember the (cbv, F lhs) pair; that is, we @@ -2626,8 +2627,8 @@ Note that * This fill-in is done when solving is complete, by restoreTyVarCycles in nestImplicTcS and runTcSWithEvBinds. -Wanted ------- +Note [Type equality cycles: Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ First, we do not cycle-break unless the LHS is a unifiable type variable See Note [Don't cycle-break Wanteds when not unifying] in GHC.Tc.Solver.Monad. @@ -2686,9 +2687,9 @@ to unify the cbvs: [W] AllEqF '[Bool] alpha Without the logic detailed in this Note, we're stuck here, as AllEqF cannot -reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, -just as described above. We thus invent cbv1 and cbv2 and unify -alpha := cbv1 -> cbv2, yielding (after zonking) +reduce and alpha cannot unify (occurs check). Let's instead apply our +cycle-breaker approach, just as described above. We thus invent cbv1 and cbv2 +and unify alpha := (cbv1 : cbv2), yielding (after zonking) [W] Head (cbv1 : cbv2) ~ cbv1 [W] Tail (cbv1 : cbv2) ~ cbv2 @@ -2726,8 +2727,8 @@ Note that we need to unify the cbvs here; if we did not, there would be no way to solve those constraints. That's why the cycle-breakers are ordinary TauTvs. -How all this is implemented ---------------------------- +Note [Type equality cycles: implementation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We implement all this via the `TEFA_Break` constructor of `TyEqFamApp`, itself stored in the `tef_fam_app` field of `TyEqFlags`, which controls the behaviour of `GHC.Tc.Utils.Unify.checkTyEqRhs`. The `TEFA_Break` @@ -2854,7 +2855,7 @@ More details: CycleBreakerOrigin. This works for both Givens and Wanteds, as we need the logic in the W case for e.g. typecheck/should_fail/T17139. Because this logic needs to work for Wanteds, too, we cannot simply look for a - CycleBreakerTv on the left: Wanteds don't use them. + GivenCycleBreakerTv on the left: Wanteds don't use them. ********************************************************************** ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -304,7 +304,7 @@ instance Outputable WorkList where ********************************************************************* -} type CycleBreakerVarStack = NE.NonEmpty (Bag (TcTyVar, TcType)) - -- ^ a stack of (CycleBreakerTv, original family applications) lists + -- ^ A stack of (GivenCycleBreakerTv, original family applications) lists -- first element in the stack corresponds to current implication; -- later elements correspond to outer implications -- used to undo the cycle-breaking needed to handle @@ -324,6 +324,8 @@ data InertSet -- See `resetInertCans` , inert_cycle_breakers :: CycleBreakerVarStack + -- The equalities for /given/ cycle breakers, GivenCycleBreakerTvs + -- See Note [ , inert_famapp_cache :: FunEqMap Reduction -- Just a hash-cons cache for use when reducing family applications @@ -1942,7 +1944,8 @@ prohibitedSuperClassSolve given_loc wanted_loc {- ********************************************************************* * * - Cycle breakers + Given Cycle breakers + See Note [Type equality cycles: Givens] in GHC.Tc.Solver.Equality * * ********************************************************************* -} ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -2344,12 +2344,12 @@ checkTypeEq ev eq_rel lhs rhs = given_pred = mkNomEqPred fam_app new_ty given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note - -- See Detail (7) of the Note + -- See Detail (7) of Note [Type equality cycles: implementation] cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin ------------------------- -- | Fill in CycleBreakerTvs with the variables they stand for. --- See Note [Type equality cycles] in GHC.Tc.Solver.Equality +-- See Note [Type equality cycles: Givens] in GHC.Tc.Solver.Equality restoreTyVarCycles :: InertSet -> TcM () restoreTyVarCycles is = TcM.liftZonkM ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -726,11 +726,11 @@ cloneMetaTyVarName name metaInfoToTyVarName :: MetaInfo -> FastString metaInfoToTyVarName meta_info = case meta_info of - TauTv -> fsLit "t" - TyVarTv -> fsLit "a" - RuntimeUnkTv -> fsLit "r" - CycleBreakerTv -> fsLit "b" - ConcreteTv {} -> fsLit "c" + TauTv -> fsLit "t" + TyVarTv -> fsLit "a" + RuntimeUnkTv -> fsLit "r" + GivenCycleBreakerTv -> fsLit "b" + ConcreteTv {} -> fsLit "c" newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi @@ -824,7 +824,7 @@ cloneAnonMetaTyVar info tv kind -- in GHC.Tc.Solver.Equality. newCycleBreakerTyVar :: TcKind -> TcM TcTyVar newCycleBreakerTyVar kind - = do { details <- newMetaDetails CycleBreakerTv + = do { details <- newMetaDetails GivenCycleBreakerTv ; name <- newMetaTyVarName (fsLit "cbv") ; return (mkTcTyVar name kind details) } ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -688,9 +688,10 @@ data MetaInfo | RuntimeUnkTv -- ^ A unification variable used in the GHCi debugger. -- It /is/ allowed to unify with a polytype, unlike TauTv - | CycleBreakerTv -- ^ Used to fix occurs-check problems in Givens - -- See Note [Type equality cycles] in - -- GHC.Tc.Solver.Equality + | GivenCycleBreakerTv -- ^ Used to fix occurs-check problems in Givens + -- Never used for Wanteds + -- See Note [Type equality cycles] in + -- GHC.Tc.Solver.Equality | ConcreteTv ConcreteTvOrigin -- ^ A unification variable that can only be unified @@ -705,11 +706,11 @@ instance Outputable MetaDetails where ppr (Indirect ty) = text "Indirect" <+> ppr ty instance Outputable MetaInfo where - ppr TauTv = text "tau" - ppr TyVarTv = text "tyv" - ppr RuntimeUnkTv = text "rutv" - ppr CycleBreakerTv = text "cbv" - ppr (ConcreteTv {}) = text "conc" + ppr TauTv = text "tau" + ppr TyVarTv = text "tyv" + ppr RuntimeUnkTv = text "rutv" + ppr GivenCycleBreakerTv = text "cbv" + ppr (ConcreteTv {}) = text "conc" -- | What caused us to create a 'ConcreteTv' metavariable? -- See Note [ConcreteTv] in GHC.Tc.Utils.Concrete. @@ -1299,7 +1300,7 @@ isRuntimeUnkTyVar tv isCycleBreakerTyVar tv | isTyVar tv -- See Note [Coercion variables in free variable lists] - , MetaTv { mtv_info = CycleBreakerTv } <- tcTyVarDetails tv + , MetaTv { mtv_info = GivenCycleBreakerTv } <- tcTyVarDetails tv = True | otherwise @@ -1350,8 +1351,8 @@ metaTyVarInfo tv isTouchableInfo :: MetaInfo -> Bool isTouchableInfo info - | CycleBreakerTv <- info = False - | otherwise = True + | GivenCycleBreakerTv <- info = False + | otherwise = True metaTyVarTcLevel :: TcTyVar -> TcLevel metaTyVarTcLevel tv ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -3235,11 +3235,11 @@ lhsPriority tv -> 5 -- Eliminate instantiation variables first | otherwise -> case info of - CycleBreakerTv -> 0 - TyVarTv -> 1 - ConcreteTv {} -> 2 - TauTv -> 3 - RuntimeUnkTv -> 4 + GivenCycleBreakerTv -> 0 + TyVarTv -> 1 + ConcreteTv {} -> 2 + TauTv -> 3 + RuntimeUnkTv -> 4 {- Note [Unification preconditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3285,7 +3285,7 @@ There are five reasons not to unify: structured type. So if 'ty' is a structured type, such as (Maybe x), don't unify. - * CycleBreakerTv: never unified, except by restoreTyVarCycles. + * GivenCycleBreakerTv: never unified, except by restoreGivenCycles. 4. (CONCRETE) A ConcreteTv can only unify with a concrete type, by definition. @@ -3390,7 +3390,7 @@ So we look for a positive reason to swap, using a three-step test: touchable and can be unified. Tie-breaking rules for MetaTvs: - - CycleBreakerTv: This is essentially a stand-in for another type; + - GivenCycleBreakerTv: This is essentially a stand-in for another type; it's untouchable and should have the same priority as a skolem: 0. - TyVarTv: These can unify only with another tyvar, but we can't unify @@ -4112,13 +4112,14 @@ wantConcreteCheck = \case -- where @cbv@ is a fresh loop-breaker tyvar (for Given), or -- just a fresh 'TauTv' (for Wanted) famAppBreaker :: FamAppBreaker a -> TcType -> TcM (PuResult a Reduction) -famAppBreaker BreakGiven fam_app +famAppBreaker BreakGiven fam_app -- Givens = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app) ; return (PuOK (unitBag (new_tv, fam_app)) (mkReflRedn Nominal (mkTyVarTy new_tv))) } -- Why reflexive? See Detail (4) of Note [Type equality cycles] -- in GHC.Tc.Solver.Equality -famAppBreaker (BreakWanted ev lhs_tv) fam_app + +famAppBreaker (BreakWanted ev lhs_tv) fam_app -- Wanteds -- Occurs check or skolem escape; so flatten = do { reason <- checkPromoteFreeVars cteInsolubleOccurs (tyVarName lhs_tv) lhs_tv_lvl @@ -4861,7 +4862,7 @@ checkTopShape info xi RuntimeUnk -> True MetaTv { mtv_info = TyVarTv } -> True _ -> False - CycleBreakerTv -> False -- We never unify these + GivenCycleBreakerTv -> False -- We never unify these _ -> True -------------------------------------------------------------------------------- @@ -5174,14 +5175,14 @@ mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars -- (as they can be unified) - -- and also for CycleBreakerTvs that mentions meta-tyvars + -- and also for GivenCycleBreakerTvs that mentions meta-tyvars mentions_meta_ty_var :: TyVar -> Bool mentions_meta_ty_var tv | isMetaTyVar tv = case metaTyVarInfo tv of -- See Examples 8 and 9 in the Note - CycleBreakerTv -> anyFreeVarsOfType mentions_meta_ty_var - (lookupCycleBreakerVar tv inert_set) + GivenCycleBreakerTv -> anyFreeVarsOfType mentions_meta_ty_var + (lookupCycleBreakerVar tv inert_set) _ -> True | otherwise = False @@ -5224,7 +5225,7 @@ We want to solve w1 using g1 and g2. The presence of g3 is irrelevant, because we cannot unify 'f[tau:1] v[tau:1]' and 'g[sk:1] x[sk:3]' due to skolem escape. -} --- | Return the type family application a CycleBreakerTv maps to. +-- | Return the type family application a GivenCycleBreakerTv maps to. lookupCycleBreakerVar :: TcTyVar -- ^ cbv, must be a CycleBreakerTv -> InertSet -> TcType -- ^ type family application the cbv maps to ===================================== testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs ===================================== @@ -22,7 +22,7 @@ it mentions b in its RHS. It thus triggers Note [Type equality cycles] in GHC.Tc.Solver.Equality. That Note says we change the situation to [G] b ~ cbv GhcPs [G] Body b ~ cbv -for some fresh CycleBreakerTv cbv. Now, our original equality looks to be let-like, +for some fresh GivenCycleBreakerTv cbv. Now, our original equality looks to be let-like, but the new cbv equality is *not* let-like -- note that the variable is on the RHS. The solution is to consider any equality whose free variables are all at the current level to not stop equalities from floating. These are called *local*. Because both View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5e6c1f43db2598cddfa54d909e2437d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5e6c1f43db2598cddfa54d909e2437d… 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][master] EPA: Use EpaLocation in EpVirtualBraces
by Marge Bot (＠marge-bot) 01 Oct '26

01 Oct '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e358619f by Alan Zimmerman at 2026-10-01T06:59:01-04:00 EPA: Use EpaLocation in EpVirtualBraces Haddock processing uses EpLayout.EpVirtualBraces to record the current layout column, for allocating haddock comments correctly. For exact printing, we need the line as well as the col, so we know how many lines to skip when the indented code block starts. This commit updates EpLayout.EpVirtualBraces so that it carries an EpaLocation instead of just the Int column, to allow it to be used for both purposes. It is a simple mechanical change, with no other impact, but it allows us to use EpLayout instead of AnnListLayout in AnnList, in the next commit in this series. - - - - - 24 changed files: - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -945,13 +945,13 @@ body :: { ([TrailingAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]) ,EpLayout) } : '{' top '}' { (fst $2, snd $2, epExplicitBraces $1 $3) } - | vocurly top close { (fst $2, snd $2, EpVirtualBraces (getVOCURLY $1)) } + | vocurly top close { (fst $2, snd $2, EpVirtualBraces (glR $1)) } body2 :: { ([TrailingAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]) ,EpLayout) } : '{' top '}' { (fst $2, snd $2, epExplicitBraces $1 $3) } - | missing_module_keyword top close { ([], snd $2, EpVirtualBraces leftmostColumn) } + | missing_module_keyword top close { ([], snd $2, EpVirtualBraces (EpaDelta noSrcSpan (SameLine 0) [])) } top :: { ([TrailingAnn] @@ -1855,7 +1855,7 @@ decllist_cls : '{' decls_cls '}' { sLL $1 $> ((epTok $1, fst $ unLoc $2, epTok $3) ,snd $ unLoc $2, epExplicitBraces $1 $3) } | vocurly decls_cls close { let { L l (anns, decls) = $2 } - in L l ((noEpTok, anns, noEpTok), decls, EpVirtualBraces (getVOCURLY $1)) } + in L l ((noEpTok, anns, noEpTok), decls, EpVirtualBraces (glR $1)) } -- Class body -- @@ -4305,7 +4305,6 @@ getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline,FunLike) getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline,FunLike) getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x -getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l getINTEGERs (L _ (ITinteger (IL src _ _))) = src getCHARs (L _ (ITchar src _)) = src ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -5,7 +5,7 @@ module GHC.Parser.Annotation ( getEpTokenBufSpan, getEpTokenLoc, getEpUniTokenLoc, TokDcolon, TokDarrow, TokRarrow, TokForall, TokStar, - EpLayout(..), + EpLayout(..), getEpaLocationCol, EpaComment(..), EpaCommentTok(..), IsUnicodeSyntax(..), HasE(..), @@ -282,7 +282,9 @@ data EpLayout = -- bar :: a -- @ EpVirtualBraces - !Int -- ^ Layout column (indentation level, begins at 1) + !EpaLocation -- ^ Layout column (indentation level, begins at 1) + -- We keep this as an 'EpaLocation' so exact printing + -- can use it too. | -- | Empty or compiler-generated blocks do not have layout information -- associated with them. @@ -290,6 +292,14 @@ data EpLayout = deriving instance Data EpLayout +-- | Used in 'GHC.Parser.Haddock' to get layout column. It assumes +-- | there is a RealSrcSpan in it, falling back to zero otherwise +getEpaLocationCol :: EpaLocation -> Int +getEpaLocationCol loc + = case loc of + EpaSpan (RealSrcSpan l _) -> srcSpanStartCol l + _ -> leftmostColumn -- should never happen in Parser output + -- --------------------------------------------------------------------- data EpaComment = ===================================== compiler/GHC/Parser/PostProcess/Haddock.hs ===================================== @@ -392,8 +392,9 @@ addHaddockInterleaveItems layout get_doc_item = go with_layout = case layout of EpNoLayout -> id EpExplicitBraces{} -> id - EpVirtualBraces n -> - let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } + EpVirtualBraces n' -> + let n = getEpaLocationCol n' + loc_range = mempty { loc_range_col = ColumnFrom (n+1) } in hoistHdkA (inLocRange loc_range) instance HasHaddock (LocatedA (HsDecl GhcPs)) where @@ -1304,7 +1305,7 @@ mkDocDecl layout (L l_comment hdk_comment) indent_mismatch = case layout of EpNoLayout -> False EpExplicitBraces{} -> False - EpVirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment) + EpVirtualBraces n -> getEpaLocationCol n /= srcSpanStartCol (psRealSpan l_comment) mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE (L l_comment hdk_comment) = ===================================== testsuite/tests/ghc-api/exactprint/T22919.stderr ===================================== @@ -34,7 +34,7 @@ { T22919.hs:1:8-13 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { T22919.hs:2:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/ghc-api/exactprint/Test20239.stderr ===================================== @@ -34,7 +34,7 @@ "-- ^ Run any arbitrary IO code") { Test20239.hs:7:86 }))])) (EpVirtualBraces - (1)) + (EpaSpan { Test20239.hs:5:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr ===================================== @@ -40,7 +40,7 @@ "-- Trailing comment, should be in HsModule extension point") { ZeroWidthSemi.hs:6:5 }))])) (EpVirtualBraces - (1)) + (EpaSpan { ZeroWidthSemi.hs:6:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T17544.hs:5:1 })) (Nothing) (Nothing)) (Just @@ -64,7 +64,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { T17544.hs:6:3 }))) [] (Nothing) (L @@ -243,7 +243,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { T17544.hs:10:3 }))) [] (Nothing) (L @@ -423,7 +423,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { T17544.hs:14:3 }))) [] (Nothing) (L @@ -603,7 +603,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { T17544.hs:18:3 }))) [] (Nothing) (L ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T17544_kw.hs:13:1 })) (Nothing) (Nothing)) (Just @@ -412,7 +412,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (5))) + (EpaSpan { T17544_kw.hs:22:5 }))) [] (Nothing) (L ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T24221.hs:3:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/module/mod185.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaDelta { <no location info> } (SameLine 0) [])) (Nothing) (Nothing)) (Nothing) ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { DumpParsedAst.hs:5:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -41,7 +41,7 @@ { DumpParsedAstComments.hs:1:1-28 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { DumpParsedAstComments.hs:9:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -45,7 +45,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { DumpSemis.hs:4:1 })) (Nothing) (Nothing)) (Just @@ -1336,7 +1336,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { DumpSemis.hs:29:3 }))) [] (Nothing) (L ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { KindSigs.hs:8:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T15323.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T15323.hs:5:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T20452.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T20452.hs:5:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T20718.stderr ===================================== @@ -68,7 +68,7 @@ "-- end 2") { T20718.hs:10:1-8 }))])) (EpVirtualBraces - (1)) + (EpaSpan { T20718.hs:8:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T20718b.stderr ===================================== @@ -55,7 +55,7 @@ { T20718b.hs:6:1-21 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { T20718b.hs:8:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T20846.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T20846.hs:3:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T23315/T23315.stderr ===================================== @@ -24,7 +24,7 @@ (EpaComments [])) (EpVirtualBraces - (1)) + (EpaSpan { T23315.hsig:3:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/printer/AnnotationNoListTuplePuns.stdout ===================================== @@ -47,7 +47,7 @@ "-- comment post B") { AnnotationNoListTuplePuns.hs:17:3 }))])) (EpVirtualBraces - (1)) + (EpaSpan { AnnotationNoListTuplePuns.hs:5:1 })) (Nothing) (Nothing)) (Just @@ -244,7 +244,7 @@ { AnnotationNoListTuplePuns.ppr.hs:1:1-32 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/printer/T18791.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T18791.hs:4:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -34,7 +34,7 @@ { Test20297.hs:1:1 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { Test20297.hs:5:1 })) (Nothing) (Nothing)) (Just @@ -476,7 +476,7 @@ { Test20297.ppr.hs:1:1 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { Test20297.ppr.hs:3:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/printer/Test24533.stdout ===================================== @@ -34,7 +34,7 @@ { Test24533.hs:1:1 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { Test24533.hs:4:1 })) (Nothing) (Nothing)) (Just @@ -694,7 +694,7 @@ { Test24533.ppr.hs:1:1 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { Test24533.ppr.hs:3:1 })) (Nothing) (Nothing)) (Just View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e358619f138494a690f47aa1f9663c8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e358619f138494a690f47aa1f9663c8… 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][master] 2 commits: Fix MultiLayerModules timeout multiplier.
by Marge Bot (＠marge-bot) 01 Oct '26

01 Oct '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 984ee82b by Andreas Klebinger at 2026-10-01T06:58:10-04:00 Fix MultiLayerModules timeout multiplier. We accidentally used the compile multiplier for ghci commands which use the run timeout setting to set the timeout. Fixes #26263 and #27796. - - - - - 50a9cf26 by Andreas Klebinger at 2026-10-01T06:58:10-04:00 testsuite: Include runtime in JUnit report. - - - - - 4 changed files: - testsuite/driver/junit.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/tests/perf/compiler/all.T Changes: ===================================== testsuite/driver/junit.py ===================================== @@ -2,10 +2,33 @@ from my_typing import * from datetime import datetime import xml.etree.ElementTree as ET -from testglobals import TestRun +from testglobals import TestRun, TestResult + + +def add_testcase(testsuite: ET.Element, test_result: TestResult) -> ET.Element: + """Adds the xml element representing the testcase.""" + testcase = ET.SubElement(testsuite, 'testcase', + classname = test_result.way, + name = '%s(%s)' % (test_result.testname, test_result.way)) + if test_result.runtime is not None: + testcase.set('time', '%.3f' % test_result.runtime) + return testcase + +def add_result(testcase: ET.Element, kind: str, res_type: str, + reason: Optional[str], text: str) -> ET.Element: + """Add a result to the testcase.""" + # GitLab ignores the message attribute and shows only the text. + result = ET.SubElement(testcase, kind, + type = res_type, + message = reason or '') + result.text = text + return result def junit(t: TestRun) -> ET.ElementTree: - testsuites = ET.Element('testsuites') + # Report time spent in testsuite. + assert t.start_time is not None + elapsed = '%.3f' % (datetime.now() - t.start_time).total_seconds() + testsuites = ET.Element('testsuites', time = elapsed) testsuite = ET.SubElement(testsuites, 'testsuite', id = "0", package = 'ghc', @@ -15,6 +38,7 @@ def junit(t: TestRun) -> ET.ElementTree: + len(t.unexpected_passes)), errors = str(len(t.framework_failures)), skipped = str(len(t.fragile_failures)), + time = elapsed, timestamp = datetime.now().isoformat()) for kind, res_type, group in [('failure', 'stat failure', t.unexpected_stat_failures), @@ -22,9 +46,7 @@ def junit(t: TestRun) -> ET.ElementTree: ('failure', 'unexpected pass', t.unexpected_passes), ('skipped', 'fragile failure', t.fragile_failures)]: for tr in group: - testcase = ET.SubElement(testsuite, 'testcase', - classname = tr.way, - name = '%s(%s)' % (tr.testname, tr.way)) + testcase = add_testcase(testsuite, tr) message = [] # type: List[str] if tr.diff: message += ['diff:', '==========', tr.diff] @@ -35,23 +57,16 @@ def junit(t: TestRun) -> ET.ElementTree: if not message: message = [tr.reason] - result = ET.SubElement(testcase, kind, - type = res_type, - message = tr.reason) - result.text = '\n'.join(message) + add_result(testcase, kind, res_type, tr.reason, '\n'.join(message)) for tr in t.framework_failures: - testcase = ET.SubElement(testsuite, 'testcase', - classname = tr.way, - name = '%s(%s)' % (tr.testname, tr.way)) - result = ET.SubElement(testcase, 'error', - type = "framework failure", - message = tr.reason) - - for tr in t.expected_passes: - testcase = ET.SubElement(testsuite, 'testcase', - classname = tr.way, - name = '%s(%s)' % (tr.testname, tr.way)) + testcase = add_testcase(testsuite, tr) + add_result(testcase, 'error', 'framework failure', tr.reason, tr.reason) + + # Expected failures (expect_broken) behaved as expected, so they count as + # passes, like in the driver's exit code. + for tr in t.expected_passes + t.expected_failures + t.fragile_passes: + add_testcase(testsuite, tr) return ET.ElementTree(testsuites) ===================================== testsuite/driver/testglobals.py ===================================== @@ -288,10 +288,10 @@ ghc_env = os.environ.copy() class TestResult: """ A result from the execution of a test. These live in the expected_passes, - framework_failures, framework_warnings, unexpected_passes, + expected_failures, framework_failures, framework_warnings, unexpected_passes, unexpected_failures, unexpected_stat_failures lists of TestRun. """ - __slots__ = 'directory', 'testname', 'reason', 'way', 'stdout', 'stderr', 'diff' + __slots__ = 'directory', 'testname', 'reason', 'way', 'stdout', 'stderr', 'diff', 'runtime' def __init__(self, directory: str, testname: TestName, @@ -299,7 +299,8 @@ class TestResult: way: WayName, stdout: Optional[str]=None, stderr: Optional[str]=None, - diff: Optional[str]=None) -> None: + diff: Optional[str]=None, + runtime: Optional[float]=None) -> None: self.directory = directory self.testname = testname self.reason = reason @@ -307,6 +308,7 @@ class TestResult: self.stdout = stdout self.stderr = stderr self.diff = diff + self.runtime = runtime # Walltime # A performance metric measured in this test run. PerfMetric = NamedTuple('PerfMetric', @@ -322,13 +324,12 @@ class TestRun: self.n_tests_skipped = 0 self.n_missing_libs = 0 - self.n_expected_passes = 0 - self.n_expected_failures = 0 self.framework_failures = [] # type: List[TestResult] self.framework_warnings = [] # type: List[TestResult] self.expected_passes = [] # type: List[TestResult] + self.expected_failures = [] # type: List[TestResult] self.unexpected_passes = [] # type: List[TestResult] self.unexpected_failures = [] # type: List[TestResult] self.unexpected_stat_failures = [] # type: List[TestResult] ===================================== testsuite/driver/testlib.py ===================================== @@ -1706,13 +1706,15 @@ async def test_common_work(name: TestName, opts, for way in do_ways: if stopping(): break + start = time.monotonic() try: await do_test(name, way, func, args, files) except KeyboardInterrupt: stopNow() except Exception as e: traceback.print_exc() - framework_fail(name, way, traceback.format_exc()) + framework_fail(name, way, traceback.format_exc(), + runtime=time.monotonic() - start) t.n_tests_skipped += len(set(all_ways) - set(do_ways)) if getTestOpts().expect == 'missing-lib': t.n_missing_libs += 1 @@ -1738,6 +1740,7 @@ async def do_test(name: TestName, files: Set[str] ) -> None: opts = getTestOpts() + start = time.monotonic() full_name = name + '(' + way + ')' test_n = len(allTestNames) @@ -1787,7 +1790,8 @@ async def do_test(name: TestName, pass else: framework_fail(name, way, - 'extra_file does not exist: ' + extra_file) + 'extra_file does not exist: ' + extra_file, + runtime=time.monotonic() - start) if func.__name__ == 'run_command' or func.__name__ == 'makefile_test' or opts.pre_cmd: # When running 'MAKE' make sure 'TOP' still points to the @@ -1811,7 +1815,8 @@ async def do_test(name: TestName, # If user used expect_broken then don't record failures of pre_cmd if exit_code != 0 and opts.expect not in ['fail']: - framework_fail(name, way, 'pre_cmd failed: {0}'.format(exit_code)) + framework_fail(name, way, 'pre_cmd failed: {0}'.format(exit_code), + runtime=time.monotonic() - start) if_verbose(1, '** pre_cmd was "{0}".'.format(override_options(opts.pre_cmd))) stderr_contents = stderr_path.read_text(encoding='UTF-8', errors='replace') stdout_contents = stdout_path.read_text(encoding='UTF-8', errors='replace') @@ -1821,45 +1826,54 @@ async def do_test(name: TestName, return result = await func(*[name,way] + args) + runtime = time.monotonic() - start if opts.expect not in ['pass', 'fail', 'missing-lib']: - framework_fail(name, way, 'bad expected ' + opts.expect) + framework_fail(name, way, 'bad expected ' + opts.expect, runtime=runtime) directory = _result_directory(opts) if way in opts.fragile_ways: if_verbose(1, '*** fragile test %s resulted in %s' % (full_name, 'pass' if result.passed else 'fail')) if result.passed: - t.fragile_passes.append(TestResult(directory, name, 'fragile', way)) + t.fragile_passes.append(TestResult(directory, name, 'fragile', way, + runtime=runtime)) else: reason = '%s (fragile)' % result.reason if result.reason else 'fragile' t.fragile_failures.append(TestResult(directory, name, reason, way, stdout=result.stdout, stderr=result.stderr, - diff=result.diff)) + diff=result.diff, + runtime=runtime)) elif result.passed: if _expect_pass(way): - t.expected_passes.append(TestResult(directory, name, "", way)) - t.n_expected_passes += 1 + t.expected_passes.append(TestResult(directory, name, "", way, + runtime=runtime)) else: if_verbose(1, '*** unexpected pass for %s' % full_name) - t.unexpected_passes.append(TestResult(directory, name, 'unexpected', way)) + t.unexpected_passes.append(TestResult(directory, name, 'unexpected', way, + runtime=runtime)) else: if _expect_pass(way): reason = result.reason tag = result.tag if tag == 'stat': if_verbose(1, '*** unexpected stat test failure for %s' % full_name) - t.unexpected_stat_failures.append(TestResult(directory, name, reason, way)) + t.unexpected_stat_failures.append(TestResult(directory, name, reason, way, + runtime=runtime)) else: if_verbose(1, '*** unexpected failure for %s' % full_name) tr = TestResult(directory, name, reason, way, stdout=result.stdout, stderr=result.stderr, - diff=result.diff) + diff=result.diff, + runtime=runtime) t.unexpected_failures.append(tr) else: - t.n_expected_failures += 1 + # Only keep the reason: nothing reports the output of expected + # failures. + t.expected_failures.append(TestResult(directory, name, result.reason, way, + runtime=runtime)) # Make is often invoked with -s, which means if it fails, we get # no feedback at all. This is annoying. So let's remove the option @@ -1873,7 +1887,8 @@ def override_options(pre_cmd): return pre_cmd -def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str) -> None: +def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str, + runtime: Optional[float]=None) -> None: opts = getTestOpts() # framework_fail can be called before testdir is initialised, # so we need to take care not to blow up with the wrong way @@ -1888,7 +1903,8 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str way2 = way if way is not None else WayName('none') if way not in opts.fragile_ways: # If the test is fragile then we rather report this as a fragile test failure - t.framework_failures.append(TestResult(directory, name2, reason, way2)) + t.framework_failures.append(TestResult(directory, name2, reason, way2, + runtime=runtime)) def framework_warn(name: TestName, way: WayName, reason: str) -> None: opts = getTestOpts() @@ -3649,9 +3665,9 @@ def summary(t: TestRun, file: TextIO, color=False, junit_path: Optional[Path]=No + repr(t.n_missing_libs).rjust(8) + ' had missing libraries\n' + '\n' - + repr(t.n_expected_passes).rjust(8) + + repr(len(t.expected_passes)).rjust(8) + ' expected passes\n' - + repr(t.n_expected_failures).rjust(8) + + repr(len(t.expected_failures)).rjust(8) + ' expected failures\n' + '\n' + repr(len(t.framework_failures)).rjust(8) ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -363,15 +363,20 @@ test('T13379', # (though the size of the fluctuations does perhaps suggest that it # would be valuable to solve the pathology in a more general way). +# Note [MultiLayerModules* test timeout] +# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# These tests are relatively sensitive to system load and cane +# take a while to run. This caused a fair number of CI failures +# in the past. So we give them some headroom. +# We need to ensure to use the right timeout for those test. In the past +# we used the compile timeout for the GHCi versions by accident. + test('MultiLayerModules', [ collect_compiler_stats('bytes allocated',2), pre_cmd('./genMultiLayerModules'), extra_files(['genMultiLayerModules']), + # See Note [MultiLayerModules* test timeout] compile_timeout_multiplier(5) - # this is _a lot_ - # but this test has been failing every now and then, - # especially on i386. Let's just give it some room - # to complete successfully reliably everywhere. ], multimod_compile, # see Note [Increased initial stack size for MultiLayerModules] @@ -382,11 +387,8 @@ test('MultiLayerModulesRecomp', [ collect_compiler_stats('bytes allocated',2), pre_cmd('$MAKE -s --no-print-directory MultiModulesRecomp'), extra_files(['genMultiLayerModules']), + # See Note [MultiLayerModules* test timeout] compile_timeout_multiplier(5) - # this is _a lot_ - # but this test has been failing every now and then, - # especially on i386. Let's just give it some room - # to complete successfully reliably everywhere. ], multimod_compile, # see Note [Increased initial stack size for MultiLayerModules] @@ -398,6 +400,7 @@ test('MultiLayerModulesTH_Make', [ collect_compiler_stats('bytes allocated',2), pre_cmd('$MAKE -s --no-print-directory MultiLayerModulesTH_Make_Prep'), extra_files(['genMultiLayerModulesTH']), + # See Note [MultiLayerModules* test timeout] compile_timeout_multiplier(5), when(arch('wasm32'), fragile(25336)), # We skip the test on darwin due to recent regression due to toolchain @@ -413,6 +416,7 @@ test('MultiLayerModulesTH_OneShot', [ collect_compiler_stats('bytes allocated',2), pre_cmd('$MAKE -s --no-print-directory MultiLayerModulesTH_OneShot_Prep'), extra_files(['genMultiLayerModulesTH']), + # See Note [MultiLayerModules* test timeout] compile_timeout_multiplier(5), when(arch('wasm32'), fragile(25336)), # We skip the test on darwin due to recent regression due to toolchain @@ -427,11 +431,8 @@ test('MultiLayerModulesDefsGhci', [ collect_compiler_residency(15), pre_cmd('./genMultiLayerModulesDefs'), extra_files(['genMultiLayerModulesDefs']), - compile_timeout_multiplier(5) - # this is _a lot_ - # but this test has been failing every now and then, - # especially on i386. Let's just give it some room - # to complete successfully reliably everywhere. + # See Note [MultiLayerModules* test timeout] + run_timeout_multiplier(5) ], ghci_script, ['MultiLayerModulesDefsGhci.script']) @@ -440,11 +441,9 @@ test('MultiLayerModulesDefsGhciWithCore', [ collect_compiler_residency(15), pre_cmd('$MAKE -s --no-print-directory MultiModulesRecompDefsWithCore'), extra_files(['genMultiLayerModulesCore', 'MultiLayerModulesDefsGhciWithCore.script']), - compile_timeout_multiplier(5), - # this is _a lot_ - # but this test has been failing every now and then, - # especially on i386. Let's just give it some room - # to complete successfully reliably everywhere. + # See Note [MultiLayerModules* test timeout] + pre_cmd_timeout_multiplier(5), + run_timeout_multiplier(5), extra_run_opts('-fwrite-if-simplified-core MultiLayerModules') ], ghci_script, @@ -454,11 +453,9 @@ test('MultiLayerModulesDefsGhciWithBytecodeFiles', [ collect_compiler_residency(15), pre_cmd('$MAKE -s --no-print-directory MultiModulesRecompDefsWithBytecodeFiles'), extra_files(['genMultiLayerModulesCore', 'MultiLayerModulesDefsGhciWithBytecodeFiles.script']), - compile_timeout_multiplier(5), - # this is _a lot_ - # but this test has been failing every now and then, - # especially on i386. Let's just give it some room - # to complete successfully reliably everywhere. + # See Note [MultiLayerModules* test timeout] + pre_cmd_timeout_multiplier(5), + run_timeout_multiplier(5), extra_run_opts('-fwrite-byte-code MultiLayerModules') ], ghci_script, @@ -468,11 +465,8 @@ test('MultiLayerModulesDefsGhcWithCore', [ collect_compiler_residency(15), pre_cmd('$MAKE -s --no-print-directory MultiModulesDefsWithCore'), extra_files(['genMultiLayerModulesCore']), + # See Note [MultiLayerModules* test timeout] compile_timeout_multiplier(5) - # this is _a lot_ - # but this test has been failing every now and then, - # especially on i386. Let's just give it some room - # to complete successfully reliably everywhere. ], multimod_compile, ['MultiLayerModules', '-v0 -fwrite-if-simplified-core']) @@ -481,11 +475,8 @@ test('MultiLayerModulesDefsGhciReload', [ collect_compiler_residency(15), pre_cmd('./genMultiLayerModulesDefs'), extra_files(['genMultiLayerModulesDefs']), - compile_timeout_multiplier(10) - # this is _a lot_ - # but this test has been failing every now and then, - # especially on i386. Let's just give it some room - # to complete successfully reliably everywhere. + # See Note [MultiLayerModules* test timeout] + run_timeout_multiplier(5) ], ghci_script, ['MultiLayerModulesDefsGhciReload.script']) @@ -504,11 +495,8 @@ test('InstanceMatching1', [ collect_compiler_stats('bytes allocated',3), pre_cmd('./genMatchingTest 1'), extra_files(['genMatchingTest']), + # See Note [MultiLayerModules* test timeout] compile_timeout_multiplier(5) - # this is _a lot_ - # but this test has been failing every now and then, - # especially on i386. Let's just give it some room - # to complete successfully reliably everywhere. ], multimod_compile, ['Defs', '-fno-code -fwrite-interface -v0']) @@ -518,11 +506,8 @@ test('MultiLayerModulesNoCode', [ collect_compiler_residency(15), pre_cmd('./genMultiLayerModulesNoCode'), extra_files(['genMultiLayerModulesNoCode']), - compile_timeout_multiplier(5) - # this is _a lot_ - # but this test has been failing every now and then, - # especially on i386. Let's just give it some room - # to complete successfully reliably everywhere. + # See Note [MultiLayerModules* test timeout] + run_timeout_multiplier(5) ], ghci_script, ['MultiLayerModulesNoCode.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c406135cc3aa0379caa402e16e1a1a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c406135cc3aa0379caa402e16e1a1a… 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][master] RTS: Update flag parsing/handling:
by Marge Bot (＠marge-bot) 01 Oct '26

01 Oct '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c406135c by Andreas Klebinger at 2026-10-01T06:57:28-04:00 RTS: Update flag parsing/handling: Using 0 as argument to any of these flags now resets the flags setting to default: - ``-n0`` disables nursery chunking. - ``-K0`` (or a bare ``-K``) removes the stack size limit. - ``-M0`` removes the heap size limit. - ``-H0`` resets the suggested heap size, including the nursery scaling set by ``-H``. - ``-AL0`` makes the large object allocation limit follow ``-A`` again. GC Generations are now limited to 64. -n larger than -A now emits a warning and disables chunking. Fixes #27830 #27829 - - - - - 10 changed files: - + changelog.d/T27830-rts-flag-bounds - docs/users_guide/runtime_control.rst - rts/RtsFlags.c - rts/include/rts/Flags.h - rts/include/rts/storage/GC.h - rts/sm/GC.c - rts/sm/Storage.c - testsuite/tests/rts/all.T - testsuite/tests/rts/rtsflags001.stderr-ws-32 - testsuite/tests/rts/rtsflags001.stderr-ws-64 Changes: ===================================== changelog.d/T27830-rts-flag-bounds ===================================== @@ -0,0 +1,17 @@ +section: rts +synopsis: Update RTS flag handling: It now respects user set -n values, allows resetting of more settings to defaults and gives more accurate bounds in errors. +description: + Using 0 as argument to any of these flags now resets the flags setting to default: + + - ``-n0`` disables nursery chunking. + - ``-K0`` (or a bare ``-K``) removes the stack size limit. + - ``-M0`` removes the heap size limit. + - ``-H0`` resets the suggested heap size, including the nursery scaling set by ``-H``. + - ``-AL0`` makes the large object allocation limit follow ``-A`` again. + + A nursery chunk size (``-n``) larger than the allocation area (``-A``) now prints a + warning and disables nursery chunking. Previously every nursery was enlarged to the chunk size. + + The number of generations (``-G``) is now limited to 64. +issues: #27830 #27829 +mrs: !16713 ===================================== docs/users_guide/runtime_control.rst ===================================== @@ -493,7 +493,7 @@ performance. Sets the limit on the total size of "large objects" (objects larger than about 3KB) that can be allocated before a GC is triggered. By default this limit is the same as the :rts-flag:`-A <-A - ⟨size⟩>` value. + ⟨size⟩>` value. ``-AL0`` restores the default. Large objects are not allocated from the normal allocation area set by the ``-A`` flag, which is why there is a separate limit for @@ -635,10 +635,11 @@ performance. Set the number of generations used by the garbage collector. The default of 2 seems to be good, but the garbage - collector can support any number of generations. Anything larger + collector can in theory support any number of generations. Anything larger than about 4 is probably not a good idea unless your program runs for a *long* time, because the oldest generation will hardly ever - get collected. + get collected. Currently the RTS hardcodes a limit of 64 generations which + seems plenty. Specifying 1 generation with ``+RTS -G1`` gives you a simple 2-space collector, as you would expect. In a 2-space collector, the :rts-flag:`-A @@ -731,6 +732,9 @@ performance. the default small ``-A`` value is suboptimal, as it can be in programs that create large amounts of long-lived data. + ``-H0`` resets both the size suggestion, and dynamic scaling enablied by a + bare ``-H``. + .. rts-flag:: -I ⟨seconds⟩ :default: 0.3 seconds in the threaded runtime, 0 in the non-threaded runtime @@ -886,7 +890,7 @@ performance. of the program. The only reason for having this option is to stop the heap growing without bound and filling up all the available swap space, which at the least will result in the program being summarily - killed by the operating system. + killed by the operating system. ``-M0`` resets any limit set by ``-M<size>``. The maximum heap size also affects other garbage collection parameters: when the amount of live data in the heap exceeds a ===================================== rts/RtsFlags.c ===================================== @@ -101,7 +101,8 @@ static int openStatsFile ( char *filename, const char *FILENAME_FMT, FILE **file_ret); static StgWord64 decodeSize ( - const char *flag, uint32_t offset, StgWord64 min, StgWord64 max); + const char *flag, uint32_t offset, StgWord64 min, StgWord64 max, + bool allow_zero); static double parseDouble ( const char *arg, bool *error); @@ -141,8 +142,8 @@ void initRtsFlagsDefaults(void) if (maxStkSize == 0) maxStkSize = 8 * 1024 * 1024; // GcFlags.maxStkSiz is 32-bit, so we need to cap to prevent overflow (#17019) - else if (maxStkSize > UINT32_MAX * sizeof(W_)) - maxStkSize = UINT32_MAX * sizeof(W_); + else if (maxStkSize > (StgWord64) UINT32_MAX * sizeof(W_)) + maxStkSize = (StgWord64) UINT32_MAX * sizeof(W_); RtsFlags.GcFlags.statsFile = NULL; RtsFlags.GcFlags.giveStats = NO_GC_STATS; @@ -155,7 +156,7 @@ void initRtsFlagsDefaults(void) /* -A default. See #16499 for a discussion about the tradeoffs */ RtsFlags.GcFlags.minAllocAreaSize = (4 * 1024 * 1024) / BLOCK_SIZE; RtsFlags.GcFlags.largeAllocLim = 0; /* defaults to minAllocAreasize */ - RtsFlags.GcFlags.nurseryChunkSize = 0; + RtsFlags.GcFlags.nurseryChunkSize = -1; /* -1: Nothing set by user, normalized to off by default, 0: off explicitly, <n>: explicit size*/ RtsFlags.GcFlags.minOldGenSize = (1024 * 1024) / BLOCK_SIZE; /* -O default */ RtsFlags.GcFlags.maxHeapSize = 0; /* off by default */ RtsFlags.GcFlags.heapLimitGrace = (1024 * 1024); @@ -331,7 +332,7 @@ usage_text[] = { " --copying-gc", " Selects the copying garbage collector to manage all generations.", "", -" -K<size> Sets the maximum stack size (default: 80% of the heap)", +" -K<size> Sets the maximum stack size (0 = unlimited, default: 80% of the heap)", " e.g.: -K32k -K512k -K8M", " -ki<size> Sets the initial thread stack size (default 1k) e.g.: -ki4k -ki2m", " -kc<size> Sets the stack chunk size (default 32k)", @@ -349,9 +350,9 @@ usage_text[] = { " memory controlled by this factor (higher is slower). Setting the factor", " to 0 means memory is not returned.", " (default 4.0)", -" -n<size> Allocation area chunk size (0 = disabled, default: 0)", +" -n<size> Allocation area chunk size (0 = disabled, default: 0, 4m for -A >= 16m)", " -O<size> Sets the minimum size of the old generation (default 1M)", -" -M<size> Sets the maximum heap size (default unlimited) e.g.: -M256k -M1G", +" -M<size> Sets the maximum heap size (0 = unlimited, default unlimited) e.g.: -M256k -M1G", " -H<size> Sets the minimum heap size (default 0M) e.g.: -H24m -H1G", " -xb<addr> Sets the address from which a suitable start for the heap memory", " will be searched from. This is useful if the default address", @@ -1239,19 +1240,19 @@ error = true; if (rts_argv[arg][2] == 'L') { RtsFlags.GcFlags.largeAllocLim = decodeSize(rts_argv[arg], 3, 2*BLOCK_SIZE, - HS_INT_MAX) / BLOCK_SIZE; + (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, true) / BLOCK_SIZE; } else { // minimum two blocks in the nursery, so that we have one // to grab for allocate(). RtsFlags.GcFlags.minAllocAreaSize = decodeSize(rts_argv[arg], 2, 2*BLOCK_SIZE, - HS_INT_MAX) / BLOCK_SIZE; + (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, false) / BLOCK_SIZE; } break; case 'n': OPTION_UNSAFE; RtsFlags.GcFlags.nurseryChunkSize - = decodeSize(rts_argv[arg], 2, 2*BLOCK_SIZE, HS_INT_MAX) + = decodeSize(rts_argv[arg], 2, 2*BLOCK_SIZE, ((StgWord64) HS_INT32_MAX) * BLOCK_SIZE, true) / BLOCK_SIZE; break; @@ -1301,9 +1302,14 @@ error = true; case 'K': OPTION_UNSAFE; - RtsFlags.GcFlags.maxStkSize = - decodeSize(rts_argv[arg], 2, 0, UINT32_MAX) - / sizeof(W_); + // -K and -K0 mean unlimited. + if (rts_argv[arg][2] == '\0') { + RtsFlags.GcFlags.maxStkSize = 0; + } else { + RtsFlags.GcFlags.maxStkSize = + decodeSize(rts_argv[arg], 2, sizeof(W_), (StgWord64) UINT32_MAX * sizeof(W_), true) + / sizeof(W_); + } break; case 'k': @@ -1311,22 +1317,22 @@ error = true; switch(rts_argv[arg][2]) { case 'c': RtsFlags.GcFlags.stkChunkSize = - decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) + decodeSize(rts_argv[arg], 3, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false) / sizeof(W_); break; case 'b': RtsFlags.GcFlags.stkChunkBufferSize = - decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) + decodeSize(rts_argv[arg], 3, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false) / sizeof(W_); break; case 'i': RtsFlags.GcFlags.initialStkSize = - decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) + decodeSize(rts_argv[arg], 3, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false) / sizeof(W_); break; default: RtsFlags.GcFlags.initialStkSize = - decodeSize(rts_argv[arg], 2, sizeof(W_), HS_WORD_MAX) + decodeSize(rts_argv[arg], 2, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false) / sizeof(W_); break; } @@ -1336,10 +1342,10 @@ error = true; OPTION_UNSAFE; if (0 == strncmp("grace=", rts_argv[arg] + 2, 6)) { RtsFlags.GcFlags.heapLimitGrace = - decodeSize(rts_argv[arg], 8, BLOCK_SIZE, HS_WORD_MAX); + decodeSize(rts_argv[arg], 8, BLOCK_SIZE, HS_WORD_MAX, false); } else { RtsFlags.GcFlags.maxHeapSize = - decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX) + decodeSize(rts_argv[arg], 2, BLOCK_SIZE, (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, true) / BLOCK_SIZE; // user give size in *bytes* but "maxHeapSize" is in // *blocks* @@ -1388,8 +1394,9 @@ error = true; #endif case 'G': OPTION_UNSAFE; - RtsFlags.GcFlags.generations = - decodeSize(rts_argv[arg], 2, 1, HS_INT_MAX); + // Capped at 64 by hardcoded array size in non-threaded RTS. + RtsFlags.GcFlags.generations = (uint32_t) + decodeSize(rts_argv[arg], 2, 1, GC_MAX_GENERATIONS, false); break; case 'H': @@ -1398,8 +1405,12 @@ error = true; RtsFlags.GcFlags.heapSizeSuggestionAuto = true; } else { RtsFlags.GcFlags.heapSizeSuggestion = (uint32_t) - (decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX) + (decodeSize(rts_argv[arg], 2, BLOCK_SIZE, (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, true) / BLOCK_SIZE); + // -H0 resets to the default of no suggestion. + if (RtsFlags.GcFlags.heapSizeSuggestion == 0) { + RtsFlags.GcFlags.heapSizeSuggestionAuto = false; + } } break; @@ -1407,7 +1418,7 @@ error = true; OPTION_UNSAFE; RtsFlags.GcFlags.minOldGenSize = (uint32_t)(decodeSize(rts_argv[arg], 2, BLOCK_SIZE, - HS_WORD_MAX) + (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, false) / BLOCK_SIZE); break; @@ -1852,14 +1863,14 @@ error = true; case 'q': OPTION_UNSAFE; RtsFlags.GcFlags.allocLimitGrace - = decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX) + = decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX, false) / BLOCK_SIZE; break; case 'r': OPTION_UNSAFE; RtsFlags.GcFlags.addressSpaceSize - = decodeSize(rts_argv[arg], 3, MBLOCK_SIZE, HS_WORD64_MAX); + = decodeSize(rts_argv[arg], 3, MBLOCK_SIZE, HS_WORD64_MAX, false); break; default: @@ -1994,9 +2005,25 @@ static void normaliseRtsOpts (void) RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize; } - // If we have -A16m or larger, use -n4m. - if (RtsFlags.GcFlags.minAllocAreaSize >= (16*1024*1024) / BLOCK_SIZE) { - RtsFlags.GcFlags.nurseryChunkSize = (4*1024*1024) / BLOCK_SIZE; + // If no explicit size was given, and we have -A16m or larger, use -n4m. + if (RtsFlags.GcFlags.nurseryChunkSize == -1) { + if (RtsFlags.GcFlags.minAllocAreaSize >= (16*1024*1024) / BLOCK_SIZE) { + RtsFlags.GcFlags.nurseryChunkSize = (4*1024*1024) / BLOCK_SIZE; + } else { + RtsFlags.GcFlags.nurseryChunkSize = 0; + } + } + else if ( RtsFlags.GcFlags.nurseryChunkSize > 0 && RtsFlags.GcFlags.nurseryChunkSize < 2) { + errorBelch("nursery chunk size (-n) must be at least %" FMT_Word " large.", (W_)(2 * BLOCK_SIZE)); + errorBelch("Disabling nursery chunking"); + RtsFlags.GcFlags.nurseryChunkSize = 0; + } + // If the user gave a chunk size respect it, unless it's larger than + // minimum allocation area. + else if ( (StgWord64) RtsFlags.GcFlags.nurseryChunkSize > (StgWord64) RtsFlags.GcFlags.minAllocAreaSize) { + errorBelch("warning: nursery chunk size (-n) is bigger than minimum alloc area size (-A), " + "disabling nursery chunking"); + RtsFlags.GcFlags.nurseryChunkSize = 0; } if (RtsFlags.ParFlags.parGcLoadBalancingGen == ~0u) { @@ -2144,10 +2171,14 @@ static void initStatsFile (FILE *f) /* ----------------------------------------------------------------------------- * decodeSize: parse a string containing a size, like 300K or 1.2M + * + * The result must lie within [min, max]. If allow_zero is set an explicitly + * given zero (e.g. "-M0") is accepted as well. -------------------------------------------------------------------------- */ static StgWord64 -decodeSize(const char *flag, uint32_t offset, StgWord64 min, StgWord64 max) +decodeSize(const char *flag, uint32_t offset, StgWord64 min, StgWord64 max, + bool allow_zero) { const char *s; StgDouble m; @@ -2206,10 +2237,14 @@ decodeSize(const char *flag, uint32_t offset, StgWord64 min, StgWord64 max) val = (StgWord64)m; - if (m < 0 || val < min || val > max) { - // printf doesn't like 64-bit format specs on Windows - // apparently, so fall back to unsigned long. - errorBelch("error in RTS option %s: size outside allowed range (%" FMT_Word " - %" FMT_Word ")", flag, (W_)min, (W_)max); + // Only a explicit zero-digit is accepted for allow_zero. + bool explicit_zero = allow_zero && *s != '\0' && m == 0; + if (m < 0 || (val < min && !explicit_zero) || val > max) { + if (allow_zero && min > 0) { + errorBelch("error in RTS option %s: size outside allowed range (0 or %" FMT_Word64 " - %" FMT_Word64 ")", flag, (StgWord64)min, (StgWord64)max); + } else { + errorBelch("error in RTS option %s: size outside allowed range (%" FMT_Word64 " - %" FMT_Word64 ")", flag, (StgWord64)min, (StgWord64)max); + } stg_exit(EXIT_FAILURE); } ===================================== rts/include/rts/Flags.h ===================================== @@ -45,7 +45,7 @@ typedef struct _GC_FLAGS { uint32_t maxHeapSize; /* in *blocks* */ uint32_t minAllocAreaSize; /* in *blocks* */ uint32_t largeAllocLim; /* in *blocks* */ - uint32_t nurseryChunkSize; /* in *blocks* */ + int32_t nurseryChunkSize; /* in *blocks*, int to distinguish default off, vs explicit off */ uint32_t minOldGenSize; /* in *blocks* */ uint32_t heapSizeSuggestion; /* in *blocks* */ bool heapSizeSuggestionAuto; @@ -80,7 +80,7 @@ typedef struct _GC_FLAGS { * to handle the exception before we * raise it again. */ - StgWord heapLimitGrace; /* units: *blocks* + StgWord heapLimitGrace; /* units: *bytes* * After a HeapOverflow exception has * been raised, how much extra space is * given to the thread to handle the ===================================== rts/include/rts/storage/GC.h ===================================== @@ -52,6 +52,8 @@ // ie. StgWord. Note that we have had some tricky int overflows in a // couple of cases caused by using ints rather than longs (e.g. #5086) +#define GC_MAX_GENERATIONS 64 + typedef StgWord memcount; typedef struct nursery_ { ===================================== rts/sm/GC.c ===================================== @@ -154,7 +154,7 @@ static Condition gc_exit_leave_now_cv; #else // THREADED_RTS // Must match the alignment of gen_workspace. -StgWord8 the_gc_thread[sizeof(gc_thread) + 64 * sizeof(gen_workspace)] +StgWord8 the_gc_thread[sizeof(gc_thread) + GC_MAX_GENERATIONS * sizeof(gen_workspace)] ATTRIBUTE_ALIGNED(GEN_WORKSPACE_ALIGNMENT); #endif // THREADED_RTS ===================================== rts/sm/Storage.c ===================================== @@ -273,7 +273,7 @@ void storageAddCapabilities (uint32_t from, uint32_t to) if (RtsFlags.GcFlags.nurseryChunkSize == 0) { new_n_nurseries = to; } else { - memcount total_alloc = to * RtsFlags.GcFlags.minAllocAreaSize; + memcount total_alloc = to * (size_t) RtsFlags.GcFlags.minAllocAreaSize; new_n_nurseries = stg_max(to, total_alloc / RtsFlags.GcFlags.nurseryChunkSize); } ===================================== testsuite/tests/rts/all.T ===================================== @@ -171,7 +171,7 @@ test('T3424', # Test for out-of-range heap size test('rtsflags001', [ only_ways(['normal']), exit_code(1), - extra_run_opts('+RTS -H0m -RTS'), + extra_run_opts('+RTS -H1k -RTS'), js_skip # JS backend uses its own rts. ], compile_and_run, ['']) ===================================== testsuite/tests/rts/rtsflags001.stderr-ws-32 ===================================== @@ -1 +1 @@ -rtsflags001: error in RTS option -H0m: size outside allowed range (4096 - 4294967295) +rtsflags001: error in RTS option -H1k: size outside allowed range (0 or 4096 - 17592186040320) ===================================== testsuite/tests/rts/rtsflags001.stderr-ws-64 ===================================== @@ -1 +1 @@ -rtsflags001: error in RTS option -H0m: size outside allowed range (4096 - 18446744073709551615) +rtsflags001: error in RTS option -H1k: size outside allowed range (0 or 4096 - 17592186040320) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c406135cc3aa0379caa402e16e1a1ac… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c406135cc3aa0379caa402e16e1a1ac… 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/jeltsch/smaller-pit] Statically guarantee the information reduction for the PIT
by Wolfgang Jeltsch (＠jeltsch) 01 Oct '26

01 Oct '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/smaller-pit at Glasgow Haskell Compiler / GHC Commits: 260b75fc by Wolfgang Jeltsch at 2026-10-01T13:55:13+03:00 Statically guarantee the information reduction for the PIT - - - - - 23 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main/Interactive.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Load.hs-boot - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/ModIface.hs - ghc/Main.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -688,7 +688,8 @@ expandFixedModuleNode key loc = do -- part of the compiler. lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case Just iface -> return (M.Succeeded iface) - Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) + Nothing -> fmap shrinkModIface <$> + readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) case read_result of M.Succeeded iface -> do -- Computer information about this node ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -372,10 +372,10 @@ lookupIfaceByModule :: HomeUnitGraph -> PackageIfaceTable -> Module - -> IO (Maybe ModIface) + -> IO (Maybe RetainedModIface) lookupIfaceByModule hug pit mod = HUG.lookupHugByModule mod hug >>= pure . \case - Just hm -> Just (hm_iface hm) + Just hm -> Just (shrinkModIface (hm_iface hm)) Nothing -> lookupModuleEnv pit mod -- If the module does come from the home package, why do we look in the PIT as well? -- (a) In OneShot mode, even home-package modules accumulate in the PIT @@ -384,7 +384,7 @@ lookupIfaceByModule hug pit mod -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. -lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe ModIface) +lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe RetainedModIface) lookupIfaceByModuleHsc hsc_env mod = do eps <- hscEPS hsc_env lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod ===================================== compiler/GHC/Driver/Main/Interactive.hs ===================================== @@ -148,7 +148,7 @@ hscIsGHCiMonad :: HscEnv -> String -> IO Name hscIsGHCiMonad hsc_env name = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name -hscGetModuleInterface :: HscEnv -> Module -> IO ModIface +hscGetModuleInterface :: HscEnv -> Module -> IO RetainedModIface hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod @@ -270,7 +270,7 @@ hscCheckSafe' m l = do _ | isHomeModule home_unit mod -> True _ -> isUnitTrusted unit_state (moduleUnit m) - lookup' :: Module -> Hsc (Maybe ModIface) + lookup' :: Module -> Hsc (Maybe RetainedModIface) lookup' m = do hsc_env <- getHscEnv iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m ===================================== compiler/GHC/Driver/Main/Passes.hs ===================================== @@ -1335,7 +1335,7 @@ hscCheckSafe' m l = do _ | isHomeModule home_unit mod -> True _ -> isUnitTrusted unit_state (moduleUnit m) - lookup' :: Module -> Hsc (Maybe ModIface) + lookup' :: Module -> Hsc (Maybe RetainedModIface) lookup' m = do hsc_env <- getHscEnv iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m ===================================== compiler/GHC/Driver/Plugins.hs ===================================== @@ -224,7 +224,7 @@ data PluginWithArgs = PluginWithArgs data LoadedPlugin = LoadedPlugin { lpPlugin :: PluginWithArgs -- ^ the actual plugin together with its commandline arguments - , lpModule :: ModIface + , lpModule :: RetainedModIface -- ^ the module containing the plugin } ===================================== compiler/GHC/Driver/Session/Inspect.hs ===================================== @@ -87,7 +87,7 @@ data ModuleInfo = ModuleInfo { minf_type_env :: TypeEnv, minf_exports :: [AvailInfo], minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface, + minf_iface :: Maybe RetainedModIface, minf_safe :: SafeHaskellMode, minf_modBreaks :: Maybe InternalModBreaks } @@ -140,7 +140,7 @@ getHomeModuleInfo hsc_env mdl = Nothing -> return Nothing Just hmi -> do let details = hm_details hmi - iface = hm_iface hmi + iface = shrinkModIface (hm_iface hmi) return (Just (ModuleInfo { minf_type_env = md_types details, minf_exports = md_exports details, @@ -187,7 +187,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do Just tyThing -> return (Just tyThing) Nothing -> liftIO (lookupType hsc_env name) -modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface :: ModuleInfo -> Maybe RetainedModIface modInfoIface = minf_iface -- | Retrieve module safe haskell mode ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -276,7 +276,7 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls u -- a) we used something from it; has something in used_names -- b) we imported it, even if we used nothing from it -- (need to recompile if its export list changes: export_fprint) - mkUsage :: Module -> ModIface -> Maybe Usage + mkUsage :: Module -> RetainedModIface -> Maybe Usage mkUsage mod iface | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids = Just $ UsagePackageModule{ usg_mod = mod, @@ -302,9 +302,9 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls u usg_entities = Map.toList ent_hashs, usg_safe = imp_safe } where - finsts_mod = mi_finsts iface + finsts_mod = mi_abi_finsts (mi_abi_hashes iface) hash_env = mi_hash_fn iface - mod_hash = mi_mod_hash iface + mod_hash = mi_abi_mod_hash (mi_abi_hashes iface) imported_exports = if not depend_on_exports then Nothing @@ -312,9 +312,9 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls u Just $ HomeModImport { hmiu_orphanLikeHash - = mi_orphan_like_hash iface + = mi_abi_orphan_like_hash (mi_abi_hashes iface) , hmiu_importedAvails - = moduleImportedAvails mod (mi_export_avails_hash iface) imp_decls + = moduleImportedAvails mod (mi_abi_export_avails_hash (mi_abi_hashes iface)) imp_decls } by_is_safe (ImportedByUser imv) = imv_is_safe imv ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -308,7 +308,7 @@ loadKnownKeyOccMaps known_key_maps :: Module -> IfM lcl KnownKeyNameMaps known_key_maps mod = do { iface <- loadInterfaceWithException doc mod ImportBySystem - ; let !abi_hash = mi_mod_hash iface + ; let !abi_hash = mi_abi_mod_hash (mi_abi_hashes iface) ; eps <- getEps ; case lookupModuleEnv (eps_known_keys eps) mod of Just (cached_hash, kk_maps) @@ -321,7 +321,7 @@ loadKnownKeyOccMaps (abi_hash, kk_maps) } ; return kk_maps } } - build_maps :: ModIface -> KnownKeyNameMaps + build_maps :: RetainedModIface -> KnownKeyNameMaps build_maps iface = (kk_map, occ_map) where kk_map :: UniqFM KnownKey Name @@ -628,7 +628,7 @@ loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> PkgQual -- "package", if any - -> RnM ModIface + -> RnM RetainedModIface loadSrcInterface doc scope mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc scope mod want_boot maybe_pkg @@ -648,7 +648,7 @@ loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> PkgQual -- "package", if any - -> RnM (MaybeErr MissingInterfaceError ModIface) + -> RnM (MaybeErr MissingInterfaceError RetainedModIface) loadSrcInterface_maybe doc scope mod want_boot maybe_pkg -- We must first find which Module this import refers to. This involves @@ -667,7 +667,7 @@ loadSrcInterface_maybe doc scope mod want_boot maybe_pkg -- rare operation, but in particular it is used to load orphan modules -- in order to pull their instances into the global package table and to -- handle some operations in GHCi). -loadModuleInterface :: SDoc -> Module -> TcM ModIface +loadModuleInterface :: SDoc -> Module -> TcM RetainedModIface loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) -- | Load interfaces for a collection of modules. @@ -681,7 +681,7 @@ loadModuleInterfaces doc mods -- | Loads the interface for a given Name. -- Should only be called for an imported name; -- otherwise loadSysInterface may not find the interface -loadInterfaceForName :: SDoc -> Name -> TcRn ModIface +loadInterfaceForName :: SDoc -> Name -> TcRn RetainedModIface loadInterfaceForName doc name = do { when debugIsOn $ -- Check pre-condition do { this_mod <- getModule @@ -690,7 +690,7 @@ loadInterfaceForName doc name initIfaceTcRn $ loadSysInterface doc (nameModule name) } -- | Loads the interface for a given Module. -loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface +loadInterfaceForModule :: SDoc -> Module -> TcRn RetainedModIface loadInterfaceForModule doc m = do -- Should not be called with this module @@ -724,23 +724,23 @@ loadWiredInHomeIface name ------------------ -- | Loads a system interface and throws an exception if it fails -loadSysInterface :: SDoc -> Module -> IfM lcl ModIface +loadSysInterface :: SDoc -> Module -> IfM lcl RetainedModIface loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem ------------------ -- | Loads a user interface and throws an exception if it fails. The first parameter indicates -- whether we should import the boot variant of the module -loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl ModIface +loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl RetainedModIface loadUserInterface is_boot doc mod_name = loadInterfaceWithException doc mod_name (ImportByUser is_boot) -loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface +loadPluginInterface :: SDoc -> Module -> IfM lcl RetainedModIface loadPluginInterface doc mod_name = loadInterfaceWithException doc mod_name ImportByPlugin ------------------ -- | A wrapper for 'loadInterface' that throws an exception if it fails -loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface +loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl RetainedModIface loadInterfaceWithException doc mod_name where_from = do dflags <- getDynFlags @@ -749,7 +749,7 @@ loadInterfaceWithException doc mod_name where_from ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr MissingInterfaceError ModIface) + -> IfM lcl (MaybeErr MissingInterfaceError RetainedModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -796,7 +796,7 @@ loadInterface doc_str mod from liftIO $ computeInterface hsc_env doc_str hi_boot_file mod ; case read_result of { Failed err -> do - { let fake_iface = emptyFullModIface mod + { let fake_iface = shrinkModIface (emptyFullModIface mod) ; updateEps_ $ \eps -> eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } @@ -856,16 +856,7 @@ loadInterface doc_str mod from ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) ; purged_hsc_env <- getTopEnv - ; let final_iface = iface - & set_mi_decls (panic "No mi_decls in PIT") - & set_mi_insts (panic "No mi_insts in PIT") - & set_mi_defaults (panic "No mi_defaults in PIT") - & set_mi_fam_insts (panic "No mi_fam_insts in PIT") - & set_mi_rules (panic "No mi_rules in PIT") - & set_mi_anns (panic "No mi_anns in PIT") - & set_mi_simplified_core (panic "No mi_simplified_core in PIT") - - bad_boot = mi_boot iface == IsBoot + ; let bad_boot = mi_boot iface == IsBoot && isJust (lookupKnotVars (if_rec_types gbl_env) mod) -- Warn against an EPS-updating import -- of one's own boot file! (one-shot only) @@ -892,7 +883,7 @@ loadInterface doc_str mod from then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls } else eps { - eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PIT = extendModuleEnv (eps_PIT eps) mod (shrinkModIface iface), eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, eps_iface_bytecode = add_bytecode (eps_iface_bytecode eps), eps_rule_base = extendRuleBaseList (eps_rule_base eps) @@ -921,10 +912,8 @@ loadInterface doc_str mod from eps_defaults = extendModuleEnv (eps_defaults eps) mod new_eps_defaults } - ; -- invoke plugins with *full* interface, not final_iface, to ensure - -- that plugins have access to declarations, etc. - res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface - ; return (Succeeded res) + ; res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface + ; return (Succeeded (shrinkModIface res)) }}}} {- Note [Loading your own hi-boot file] ===================================== compiler/GHC/Iface/Load.hs-boot ===================================== @@ -2,7 +2,7 @@ module GHC.Iface.Load where import GHC.Unit.Module (Module) import GHC.Tc.Utils.Monad (IfM) -import GHC.Unit.Module.ModIface (ModIface) +import GHC.Unit.Module.ModIface (RetainedModIface) import GHC.Utils.Outputable (SDoc) -loadSysInterface :: SDoc -> Module -> IfM lcl ModIface +loadSysInterface :: SDoc -> Module -> IfM lcl RetainedModIface ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -707,7 +707,7 @@ checkDependencies hsc_env summary iface return $ needsRecompileBecause $ ModulePackageChanged new_name -needInterface :: Module -> (ModIface -> IO RecompileRequired) +needInterface :: Module -> (RetainedModIface -> IO RecompileRequired) -> IfG RecompileRequired needInterface mod continue = do @@ -727,7 +727,7 @@ needBytecode mod continue Nothing -> return $ NeedsRecompile MustCompile Just mbc -> liftIO $ continue mbc -tryGetModIface :: String -> Module -> IfG (Maybe ModIface) +tryGetModIface :: String -> Module -> IfG (Maybe RetainedModIface) tryGetModIface doc_msg mod = do -- Load the imported interface if possible logger <- getLogger @@ -779,7 +779,7 @@ checkModUsage _ UsagePackageModule{ logger <- getLogger needInterface mod $ \iface -> do let reason = ModuleChanged (moduleName mod) - checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface) + checkModuleFingerprint logger reason old_mod_hash (mi_abi_mod_hash (mi_abi_hashes iface)) -- We only track the ABI hash of package modules, rather than -- individual entity usages, so if the ABI hash changes we must -- recompile. This is safe but may entail more recompilation when @@ -789,7 +789,7 @@ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_ha logger <- getLogger needInterface mod $ \iface -> do let reason = ModuleChangedRaw (moduleName mod) - checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface) + checkModuleFingerprint logger reason old_mod_hash (mi_abi_mod_hash (mi_abi_hashes iface)) checkModUsage _ UsageHomeModuleBytecode{ usg_mod_name = mod_name , usg_unit_id = uid , usg_bytecode_hash = old_bytecode_hash } = do @@ -810,7 +810,7 @@ checkModUsage _ UsageHomeModule{ logger <- getLogger needInterface mod $ \iface -> do let - new_mod_hash = mi_mod_hash iface + new_mod_hash = mi_abi_mod_hash (mi_abi_hashes iface) new_decl_hash = mi_hash_fn iface reason = ModuleChanged (moduleName mod) @@ -864,7 +864,7 @@ checkModUsage fc UsageDirectory{ usg_dir_path = dir, -- Does this require recompilation? -- -- See Note [When to recompile when export lists change?] -checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> ModIface -> IO RecompileRequired +checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> RetainedModIface -> IO RecompileRequired checkHomeModImport _ _ Nothing _ = return UpToDate checkHomeModImport logger reason (Just (HomeModImport old_orphan_like_hash old_avails)) @@ -901,8 +901,8 @@ checkHomeModImport logger reason 2 (ppr changes) return $ needsRecompileBecause reason where - new_orphan_like_hash = mi_orphan_like_hash iface - new_avails_hash = mi_export_avails_hash iface + new_orphan_like_hash = mi_abi_orphan_like_hash (mi_abi_hashes iface) + new_avails_hash = mi_abi_export_avails_hash (mi_abi_hashes iface) new_exports = mi_exports iface -- | The exported avails of a module have changed. Should this cause recompilation @@ -1617,7 +1617,7 @@ getOrphanHashes hsc_env mods = do get_orph_hash mod = do iface <- initIfaceLoad hsc_env . withIfaceErr ctx $ loadInterface (text "getOrphanHashes") mod ImportBySystem - return (mi_orphan_hash iface) + return (mi_abi_orphan_hash (mi_abi_hashes iface)) mapM get_orph_hash mods ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -517,7 +517,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit -> S.Set UnitId - -> ModIface + -> RetainedModIface -> IsSafeImport -> IsBootInterface -> ImportedBy @@ -525,8 +525,8 @@ calculateAvails :: HomeUnit calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by = let imp_mod = mi_module iface imp_sem_mod= mi_semantic_module iface - orph_iface = mi_orphan iface - has_finsts = mi_finsts iface + orph_iface = mi_abi_orphan (mi_abi_hashes iface) + has_finsts = mi_abi_finsts (mi_abi_hashes iface) deps = mi_deps iface trust = getSafeMode $ mi_trust iface trust_pkg = mi_trust_pkg iface @@ -1209,7 +1209,7 @@ gresFromAvail hsc_env prov avail = gresFromAvails :: HscEnv -> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] gresFromAvails hsc_env prov = concatMap (gresFromAvail hsc_env prov) -importsFromIface :: HscEnv -> ModIface -> ImpDeclSpec -> Maybe NameSet -> GlobalRdrEnv +importsFromIface :: HscEnv -> RetainedModIface -> ImpDeclSpec -> Maybe NameSet -> GlobalRdrEnv importsFromIface hsc_env iface decl_spec hidden = mkGlobalRdrEnv $ case hidden of Nothing -> all_gres Just hidden_names -> filter (not . (`elemNameSet` hidden_names) . greName) all_gres @@ -1225,7 +1225,7 @@ rnNamespaceSpecifier (DataNamespaceSpecifier x) = DataNamespaceSpecifier x filterImports :: HasDebugCallStack => HscEnv - -> ModIface + -> RetainedModIface -> ImpDeclSpec -- ^ Import spec -> Maybe (ImportListInterpretation, [LIE GhcPs]) @@ -2327,7 +2327,7 @@ getMinimalImports ie_decls where doc = text "Compute minimal imports for" <+> ppr decl - to_ie :: GlobalRdrEnv -> ModIface -> AvailInfo -> RnM [IE GhcRn] + to_ie :: GlobalRdrEnv -> RetainedModIface -> AvailInfo -> RnM [IE GhcRn] -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. @@ -2529,7 +2529,7 @@ DRFPatSynExport for a test of this. -} badImportItemErr - :: ModIface -> ImpDeclSpec -> IE GhcPs + :: RetainedModIface -> ImpDeclSpec -> IE GhcPs -> IsSubordinateError -> [AvailInfo] -> TcRn (NonEmpty ImportLookupReason) ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -534,7 +534,7 @@ warnIfDeclDeprecated gre@(GRE { gre_imp = iss }) definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" -lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) +lookupImpDeclDeprec :: RetainedModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeclDeprec iface gre -- Bleat if the thing, or its parent, is warn'd = mi_decl_warn_fn iface (greOccName gre) `mplus` ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -190,7 +190,7 @@ checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of -> throwIO (InstallationError "Plugins require -fno-external-interpreter") _ -> pure () -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [LinkableUsage], PkgsLoaded) +loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, RetainedModIface, [LinkableUsage], PkgsLoaded) loadPlugin' occ_name plugin_name hsc_env mod_name = do { let plugin_rdr_name = mkRdrQual mod_name occ_name dflags = hsc_dflags hsc_env @@ -341,7 +341,7 @@ lessUnsafeCoerce logger context what = do -- Need the module as well to record information in the interface file lookupRdrNameInModuleForPlugins :: HasDebugCallStack => HscEnv -> ModuleName -> RdrName - -> IO (Maybe (Name, ModIface)) + -> IO (Maybe (Name, RetainedModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let dflags = hsc_dflags hsc_env -- First find the unit the module resides in by searching exposed units and home modules ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -6386,7 +6386,7 @@ pprImportLookup :: ImportLookupReason -> SDoc pprImportLookup = \case ImportLookupBad k iface decl_spec ie _exts -> let - pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc + pprImpDeclSpec :: RetainedModIface -> ImpDeclSpec -> SDoc pprImpDeclSpec iface decl_spec = quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of IsBoot -> text "(hi-boot interface)" ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -215,7 +215,7 @@ import GHC.Types.DefaultEnv (ClassDefaults) import GHC.Unit.Types (Module) import GHC.Unit.State (UnitState) -import GHC.Unit.Module.ModIface (ModIface) +import GHC.Unit.Module.ModIface (RetainedModIface) import GHC.Utils.Outputable @@ -6635,7 +6635,7 @@ data ImportLookupReason where T9006, T11071, T9905fail2, T5385, T10668 -} ImportLookupBad :: BadImportKind - -> ModIface + -> RetainedModIface -> ImpDeclSpec -> IE GhcPs -> ImportLookupExtensions ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1693,7 +1693,7 @@ lookupArgDoc i nm = do _ -> pure Nothing -- | Returns the module a Name belongs to, if it is isn't local. -getExternalModIface :: Name -> TcM (Maybe ModIface) +getExternalModIface :: Name -> TcM (Maybe RetainedModIface) getExternalModIface nm = do isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm if isLocal ===================================== compiler/GHC/Tc/Instance/Family.hs ===================================== @@ -308,7 +308,7 @@ checkFamInstConsistency directlyImpMods ifc <- modIface mod deps <- dep_finsts . mi_deps <$> modIface mod pure $ - if mi_finsts ifc + if mi_abi_finsts (mi_abi_hashes ifc) then mod:deps else deps ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2964,7 +2964,7 @@ externaliseAndTidyId this_mod id -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) +getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe RetainedModIface) getModuleInterface hsc_env mod = runTcInteractive NoTcMPlugins hsc_env $ loadModuleInterface (text "getModuleInterface") mod ===================================== compiler/GHC/Unit/External.hs ===================================== @@ -49,7 +49,7 @@ type PackageAnnEnv = AnnEnv type PackageCompleteMatches = CompleteMatches -- | Helps us find information about modules in the imported packages -type PackageIfaceTable = ModuleEnv ModIface +type PackageIfaceTable = ModuleEnv RetainedModIface -- Domain = modules in the imported packages -- | Constructs an empty PackageIfaceTable ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} module GHC.Unit.Module.ModIface ( ModIface @@ -68,6 +69,7 @@ module GHC.Unit.Module.ModIface , set_mi_fix_fn , set_mi_hash_fn , completePartialModIface + , shrinkModIface , IfaceBinHandle(..) , PartialModIface , RetainedModIface @@ -82,8 +84,6 @@ module GHC.Unit.Module.ModIface , IfaceAnnotationsData , IfaceDeclsData , IfaceDefaultsData - , IfaceClsInstsData - , IfaceFamInstsData , IfaceRulesData , IfaceCompleteMatchesData , IfaceAbiHashesData @@ -268,23 +268,13 @@ type family IfaceAnnotationsData (phase :: ModIfacePhase) where type family IfaceDeclsData (phase :: ModIfacePhase) where IfaceDeclsData 'ModIfaceCore = [IfaceDecl] IfaceDeclsData 'ModIfaceFinal = [(Fingerprint, IfaceDecl)] - IfaceDeclsData 'ModIfaceRetained = () + IfaceDeclsData 'ModIfaceRetained = [IfaceDecl] type family IfaceDefaultsData (phase :: ModIfacePhase) where IfaceDefaultsData 'ModIfaceCore = [IfaceDefault] IfaceDefaultsData 'ModIfaceFinal = [IfaceDefault] IfaceDefaultsData 'ModIfaceRetained = () -type family IfaceClsInstsData (phase :: ModIfacePhase) where - IfaceClsInstsData 'ModIfaceCore = [IfaceClsInst] - IfaceClsInstsData 'ModIfaceFinal = [IfaceClsInst] - IfaceClsInstsData 'ModIfaceRetained = () - -type family IfaceFamInstsData (phase :: ModIfacePhase) where - IfaceFamInstsData 'ModIfaceCore = [IfaceFamInst] - IfaceFamInstsData 'ModIfaceFinal = [IfaceFamInst] - IfaceFamInstsData 'ModIfaceRetained = () - type family IfaceRulesData (phase :: ModIfacePhase) where IfaceRulesData 'ModIfaceCore = [IfaceRule] IfaceRulesData 'ModIfaceFinal = [IfaceRule] @@ -413,9 +403,9 @@ data IfacePublic_ phase = IfacePublic { -- Instance declarations and rules - mi_insts_ :: IfaceClsInstsData phase, -- ^ Sorted class instance - mi_fam_insts_ :: IfaceFamInstsData phase, -- ^ Sorted family instances - mi_rules_ :: IfaceRulesData phase, -- ^ Sorted rules + mi_insts_ :: [IfaceClsInst], -- ^ Sorted class instance + mi_fam_insts_ :: [IfaceFamInst], -- ^ Sorted family instances + mi_rules_ :: IfaceRulesData phase, -- ^ Sorted rules mi_trust_ :: IfaceTrustInfo, @@ -608,7 +598,7 @@ mi_orphan_hash iface = mi_abi_orphan_hash (mi_abi_hashes iface) -- | Old-style accessor for whether or not the ModIface came from an hs-boot -- file. -mi_boot :: ModIface -> IsBootInterface +mi_boot :: ModIface_ phase -> IsBootInterface mi_boot iface = if mi_hsc_src iface == HsBootFile then IsBoot else NotBoot @@ -618,7 +608,7 @@ mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface) -- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be -- found, 'defaultFixity' is returned instead. -mi_fix :: ModIface -> OccName -> Fixity +mi_fix :: ModIface_ phase -> OccName -> Fixity mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity -- | The semantic module for this interface; e.g., if it's a interface @@ -634,7 +624,7 @@ mi_semantic_module iface = mi_mod_info_semantic_module (mi_mod_info iface) -- | The "precise" free holes, e.g., the signatures that this -- 'ModIface' depends on. -mi_free_holes :: ModIface -> UniqDSet ModuleName +mi_free_holes :: ModIface_ phase -> UniqDSet ModuleName mi_free_holes iface = case getModuleInstantiation (mi_module iface) of (_, Just indef) @@ -851,8 +841,8 @@ emptyIfaceModInfo mod = IfaceModInfo emptyPublicModIface :: IfaceAnnotationsData phase -> IfaceDeclsData phase -> IfaceDefaultsData phase - -> IfaceClsInstsData phase - -> IfaceFamInstsData phase + -> [IfaceClsInst] + -> [IfaceFamInst] -> IfaceRulesData phase -> IfaceCompleteMatchesData phase -> IfaceAbiHashesData phase @@ -930,8 +920,6 @@ instance ( NFData (IfaceSelfRecompData phase) , NFData (IfaceAnnotationsData phase) , NFData (IfaceDeclsData phase) , NFData (IfaceDefaultsData phase) - , NFData (IfaceClsInstsData phase) - , NFData (IfaceFamInstsData phase) , NFData (IfaceRulesData phase) , NFData (IfaceCompleteMatchesData phase) , NFData (IfaceAbiHashesData phase) @@ -970,8 +958,6 @@ instance NFData IfaceAbiHashes where instance ( NFData (IfaceAnnotationsData phase) , NFData (IfaceDeclsData phase) , NFData (IfaceDefaultsData phase) - , NFData (IfaceClsInstsData phase) - , NFData (IfaceFamInstsData phase) , NFData (IfaceRulesData phase) , NFData (IfaceCompleteMatchesData phase) , NFData (IfaceAbiHashesData phase) @@ -1051,7 +1037,6 @@ completePartialModIface partial iface_hash decls extra_decls final_exts cache = , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing , mi_iface_hash_ = iface_hash } - where -- | Given a 'PartialIfacePublic', turn it into an 'IfacePublic' by completing -- missing fields. @@ -1066,6 +1051,30 @@ completePublicModIface decls abi_hashes cache partial = partial , mi_caches_ = cache } +shrinkModIface :: ModIface -> RetainedModIface +shrinkModIface PrivateModIface {..} + = PrivateModIface + { + mi_hi_bytes_ = RetainedIfaceBinHandle, + mi_public_ = shrinkIfacePublic mi_public_, + mi_self_recomp_ = (), + mi_simplified_core_ = (), + mi_ext_fields_ = (), + .. + } + +shrinkIfacePublic :: IfacePublic -> RetainedIfacePublic +shrinkIfacePublic IfacePublic {..} + = IfacePublic + { + mi_anns_ = (), + mi_decls_ = map snd mi_decls_, + mi_defaults_ = (), + mi_rules_ = (), + mi_complete_matches_ = (), + .. + } + set_mi_mod_info :: IfaceModInfo -> ModIface_ phase -> ModIface_ phase set_mi_mod_info val iface = clear_mi_hi_bytes $ iface { mi_mod_info_ = val } @@ -1107,10 +1116,10 @@ set_mi_warns val = set_mi_public (\iface -> iface { mi_warns_ = val }) set_mi_anns :: IfaceAnnotationsData phase -> ModIface_ phase -> ModIface_ phase set_mi_anns val = set_mi_public (\iface -> iface { mi_anns_ = val }) -set_mi_insts :: IfaceClsInstsData phase -> ModIface_ phase -> ModIface_ phase +set_mi_insts :: [IfaceClsInst] -> ModIface_ phase -> ModIface_ phase set_mi_insts val = set_mi_public (\iface -> iface { mi_insts_ = val }) -set_mi_fam_insts :: IfaceFamInstsData phase -> ModIface_ phase -> ModIface_ phase +set_mi_fam_insts :: [IfaceFamInst] -> ModIface_ phase -> ModIface_ phase set_mi_fam_insts val = set_mi_public (\iface -> iface { mi_fam_insts_ = val }) set_mi_rules :: IfaceRulesData phase -> ModIface_ phase -> ModIface_ phase @@ -1282,8 +1291,8 @@ pattern ModIface :: -> IfaceSimplifiedCoreData phase -> IfaceDefaultsData phase -> IfaceTopEnv - -> IfaceClsInstsData phase - -> IfaceFamInstsData phase + -> [IfaceClsInst] + -> [IfaceFamInst] -> IfaceRulesData phase -> IfaceTrustInfo -> Bool ===================================== ghc/Main.hs ===================================== @@ -515,7 +515,7 @@ abiHash strs = do put_ bh hiVersion -- package hashes change when the compiler version changes (for now) -- see #5328 - mapM_ (put_ bh . mi_mod_hash) ifaces + mapM_ (put_ bh . mi_abi_mod_hash . mi_abi_hashes) ifaces f <- fingerprintBinMem bh putStrLn (showPpr dflags f) ===================================== utils/haddock/haddock-api/src/Haddock/Interface.hs ===================================== @@ -74,7 +74,7 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable import GHC.Unit.Module.Graph (ModuleGraphNode (..), ModuleNodeInfo(..)) import GHC.Unit.Module.ModDetails -import GHC.Unit.Module.ModIface (mi_semantic_module, mi_boot) +import GHC.Unit.Module.ModIface (RetainedModIface, shrinkModIface, mi_semantic_module, mi_boot) import GHC.Unit.Module.ModSummary (isBootSummary) import GHC.Utils.Outputable (Outputable, (<+>), pprModuleName, text) import GHC.Utils.Error (withTiming) @@ -254,7 +254,7 @@ dropErr :: MaybeErr e a -> Maybe a dropErr (Succeeded a) = Just a dropErr (Failed _) = Nothing -loadHiFile :: HscEnv -> Outputable.SDoc -> Module -> IO (ModIface, ([ClsInst], [FamInst])) +loadHiFile :: HscEnv -> Outputable.SDoc -> Module -> IO (RetainedModIface, ([ClsInst], [FamInst])) loadHiFile hsc_env doc theModule = initIfaceLoad hsc_env $ do mod_iface <- loadSysInterface doc theModule @@ -288,7 +288,7 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap warningMap = do let cls_insts = instEnvElts . md_insts $ hm_details hmi fam_insts = md_fam_insts $ hm_details hmi - pure (hm_iface hmi, (cls_insts, fam_insts)) + pure (shrinkModIface (hm_iface hmi), (cls_insts, fam_insts)) !interface <- do logger <- getLogger ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Create.hs ===================================== @@ -81,7 +81,7 @@ createInterface1 => [Flag] -> UnitState -> ModSummary - -> ModIface + -> RetainedModIface -> IfaceMap -> InstIfaceMap -> ([ClsInst], [FamInst]) @@ -105,7 +105,7 @@ createInterface1' -> UnitState -> DynFlags -> FilePath - -> ModIface + -> RetainedModIface -> IfaceMap -> InstIfaceMap -> ([ClsInst], [FamInst]) @@ -150,7 +150,7 @@ createInterface1' flags unit_state dflags hie_file mod_iface ifaces inst_ifaces def_meths_env = mkOccEnv def_meths def_meths = [ (nameOccName nm, nm) - | (_, IfaceId{ifName = nm}) <- mi_decls mod_iface + | IfaceId{ifName = nm} <- mi_decls mod_iface , let occ = nameOccName nm , isDefaultMethodOcc occ ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/260b75fcb25d56ba552159637ef7005… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/260b75fcb25d56ba552159637ef7005… 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/hsmodulename] ttg: HsModuleName in the AST, ModuleName in GHC
by Rodrigo Mesquita (＠alt-romes) 01 Oct '26

01 Oct '26

Rodrigo Mesquita pushed to branch wip/romes/hsmodulename at Glasgow Haskell Compiler / GHC Commits: 84d3cd55 by Rodrigo Mesquita at 2026-10-01T10:39:09+01:00 ttg: HsModuleName in the AST, ModuleName in GHC This commit makes the AST fully independent from GHC by parsing a "module name" as an `HsModuleName (= HText)` rather than constructing an `ModuleName (= FastString)` straight away. In the GHC side, everything remains as a `ModuleName`. We turn AST `HsModuleName`s into fast strings with the cheap `mkFastStringShortText` when we process the AST for manipulation within the compiler. There are no performance regressions introduced by this approach. This is the final piece of #21592 Alternative plans were discussed in gitlab.haskell.org/ghc/ghc/-/merge_requests/16546#note_694647, but the Simon suggested one won in simplicity and performance when compared against my attempt at implementing my original plan of having a family `ModuleNameP`. - - - - - 89 changed files: - compiler/GHC.hs - compiler/GHC/Builtin/Modules.hs - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Show.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Opt/CallerCC/Types.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Pipeline.hs-boot - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/Phases.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Debug.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/String.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/UnresolvedImport.hs - compiler/GHC/Unit/Home.hs - compiler/GHC/Unit/Module.hs - compiler/GHC/Unit/Module/Env.hs - + compiler/GHC/Unit/Module/Name.hs - compiler/GHC/Unit/Parser.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Unit/Types.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Language/Haskell/Syntax/Module/Name.hs - compiler/Language/Haskell/Syntax/Text.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - linters/lint-codes/LintCodes/Static.hs - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84d3cd5501dbce8a770764eb0ee4605… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84d3cd5501dbce8a770764eb0ee4605… 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] 2 commits: Add regression test for #7803
by Hannes Siebenhandl (＠fendor) 01 Oct '26

01 Oct '26

Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC Commits: 234bab08 by Vladislav Zavialov at 2026-09-29T17:22:54-04:00 Add regression test for #7803 Commit 2effe18ab5, first shipped with GHC 8.2.1, fixed #7803 "Superclass methods are left unspecialized". This change turns the example from the ticket description into a regression test, checking that foo1 is fully specialised at Double, with no calls to the overloaded exp5Tail. Closes #7803 Assisted-by: Claude Opus 5 - - - - - 718deaad by fendor at 2026-10-01T11:42:09+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. Once the `UnitState` is created using `initUnits`, we store the corrected `HomeUnit` in the `HomeUnitEnv` again. This avoids many partial functions that should have never been partial in the first case. Closes #27632 - - - - - 26 changed files: - + changelog.d/home-unit - 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 - + testsuite/tests/simplCore/should_compile/T7803.hs - + testsuite/tests/simplCore/should_compile/T7803.stderr - + testsuite/tests/simplCore/should_compile/T7803a.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/home-unit ===================================== @@ -0,0 +1,26 @@ +section: compiler +synopsis: The compiler session always requires a `HomeUnit`. +description: { + We change `HomeUnitEnv` to always require a `HomeUnit` value. + Most parts of the compiler simply `panic` when the `HomeUnit` is missing, + and GHC API users are often forced to create dummy `HomeUnit` values for the API any way. + Thus, by demanding a `HomeUnit` in the `HomeUnitEnv`, we can avoid many sources of `panic`s, and simplify + multiple code paths and some APIs. + + We can always create a dummy `HomeUnit` value based on the `UnitId` of the + `HomeUnitEnv.homeUnitEnv_dflags.homeUnitId_`. + This `HomeUnit` might be wrong, as we don't know exactly what kind of `HomeUnit` it is until we have called + `initUnits` on the `HomeUnitEnv` contents themselves. + Once `initUnits` is called, we store the corrected `HomeUnit` in the `HomeUnitEnv`. + + From an API perspective, very little changes, since when users didn't have a real `HomeUnit` value, they needed to create + a dummy value already for most GHC API functions. + + The reason the `HomeUnit` used to be optional is to indicate which parts of the GHC API require certain initialisation steps, + such as calling `initUnits` on the `HomeUnitEnv`. The `HomeUnit` is a poor reflection of this requirement, which is why + we decided to make it mandatory whenever there is a `HomeUnitEnv`. + In the future, we might want to reflect this information based on the existence of a `HomeUnitEnv`, which we should only create + if the compiler session actually needs it. +} +mrs: !15885 +issues: #27632 ===================================== 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 @@ -237,16 +238,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 ===================================== @@ -782,14 +782,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 @@ -885,7 +885,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] @@ -1050,12 +1050,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 @@ -1079,13 +1079,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 @@ -1142,13 +1141,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 @@ -1156,7 +1155,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 @@ -1230,7 +1229,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 @@ -1269,7 +1268,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' = ===================================== testsuite/tests/simplCore/should_compile/T7803.hs ===================================== @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -ddump-simpl #-} + +-- #7803: foo1 should be fully specialised at Double. In the bug report +-- it ended up calling the overloaded exp5Tail (with a dictionary argument), +-- because the specialiser ran before the overloaded call was floated to +-- the top level. So the dumped Core for this module must mention no +-- exp5Tail at all. +module T7803 (foo1) where + +import T7803a + +bar :: Floating a => a -> a -> a +bar z = subtract (evaluate integ z) . evaluate integ + where + integ = indefinite (Piecewise [Poly4 1]) +{-# SPECIALIZE bar :: Double -> Double -> Double #-} + +foo :: Floating a => a -> a -> a +foo x = bar x +{-# SPECIALIZE foo :: Double -> Double -> Double #-} + +foo1 :: Double -> Double -> Double +foo1 x = foo x ===================================== testsuite/tests/simplCore/should_compile/T7803.stderr ===================================== @@ -0,0 +1 @@ +foo1 ===================================== testsuite/tests/simplCore/should_compile/T7803a.hs ===================================== @@ -0,0 +1,73 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T7803a + ( Evaluate (..) + , HasIntegral (..) + , Poly4 (..) + , Domain + , IntOfLogPoly4 (..) + , Piecewise (..) + ) where + +import Data.Kind (Constraint, Type) + +class Evaluate poly where + evaluate :: (Domain' poly a) => poly a -> a -> a + +class Evaluate (IntegralOf poly) => HasIntegral poly where + type IntegralOf poly :: Type -> Type + indefinite :: (Domain' poly a, Domain' (IntegralOf poly) a) + => poly a -> IntegralOf poly a + +type family Domain (f :: Type -> Type) a :: Constraint + +class Domain f a => Domain' f a +instance Domain f a => Domain' f a + +newtype Poly4 a = Poly4 { poly4_a :: a } + +type instance Domain Poly4 a = Fractional a + +data IntOfLogPoly4 a = IntOfLogPoly4 { ilp4_k :: !a, ilp4_u :: !a } + +type instance Domain IntOfLogPoly4 a = Floating a + +instance Evaluate IntOfLogPoly4 where + evaluate (IntOfLogPoly4 k _) x = k + x * exp5Tail (- log x) + {-# INLINE evaluate #-} + +{-# RULES "exp5Tail/Double" exp5Tail = exp5TailDouble #-} +{-# NOINLINE exp5Tail #-} + +exp5Tail :: (Floating a) => a -> a +exp5Tail x = x / 120 + +exp5TailDouble :: Double -> Double +exp5TailDouble x = x / 120 + +instance HasIntegral Poly4 where + type IntegralOf Poly4 = IntOfLogPoly4 + indefinite = \ (Poly4 a) -> IntOfLogPoly4 0 a + {-# INLINE indefinite #-} + +newtype Piecewise poly a = Piecewise { unPiecewise :: [poly a] } + +type instance Domain (Piecewise poly) a = (Domain poly a, Num a) + +instance (Evaluate poly) => Evaluate (Piecewise poly) where + evaluate = \ (Piecewise pp) x -> + case pp of + p : _ -> evaluate p x + [] -> error "evaluate: empty Piecewise" + {-# INLINE evaluate #-} + +instance (HasIntegral poly) => HasIntegral (Piecewise poly) where + type IntegralOf (Piecewise poly) = Piecewise (IntegralOf poly) + indefinite (Piecewise m) = Piecewise $ map indefinite m + {-# INLINE indefinite #-} ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -148,6 +148,13 @@ test('T7785', [ only_ways(['optasm']), grep_errmsg(r'SPEC') ], compile, ['-ddump-cse']) +# T7803: we expect NO calls to the overloaded 'exp5Tail' in T7803.hs +# In the bug report #7803, the unspecialised call was signalled by 'exp5Tail' +# in foo1's Core, so we grep for that; also for 'foo1', lest we dump nothing +# One module, T7803.hs, has OPTIONS_GHC -ddump-simpl +test('T7803', [ grep_errmsg(r'exp5Tail|foo1') ], + multimod_compile, ['T7803', '-O2 -v0 -dsuppress-all -dsuppress-uniques -dno-typeable-binds']) + test('T7702', [extra_files(['T7702plugin']), pre_cmd('$MAKE -s --no-print-directory -C T7702plugin package.T7702 TOP={top}'), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82b7467cd1a20919bc6c24c1b99b42… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82b7467cd1a20919bc6c24c1b99b42… 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) 01 Oct '26

01 Oct '26

Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC Commits: 82b7467c by fendor at 2026-10-01T11:40:44+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. Once the `UnitState` is created using `initUnits`, we store the corrected `HomeUnit` in the `HomeUnitEnv` again. This avoids many partial functions that should have never been partial in the first case. Closes #27632 - - - - - 22 changed files: - + changelog.d/home-unit - 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: ===================================== changelog.d/home-unit ===================================== @@ -0,0 +1,26 @@ +section: compiler +synopsis: The compiler session always requires a `HomeUnit`. +description: { + We change `HomeUnitEnv` to always require a `HomeUnit` value. + Most parts of the compiler simply `panic` when the `HomeUnit` is missing, + and GHC API users are often forced to create dummy `HomeUnit` values for the API any way. + Thus, by demanding a `HomeUnit` in the `HomeUnitEnv`, we can avoid many sources of `panic`s, and simplify + multiple code paths and some APIs. + + We can always create a dummy `HomeUnit` value based on the `UnitId` of the + `HomeUnitEnv.homeUnitEnv_dflags.homeUnitId_`. + This `HomeUnit` might be wrong, as we don't know exactly what kind of `HomeUnit` it is until we have called + `initUnits` on the `HomeUnitEnv` contents themselves. + Once `initUnits` is called, we store the corrected `HomeUnit` in the `HomeUnitEnv`. + + From an API perspective, very little changes, since when users didn't have a real `HomeUnit` value, they needed to create + a dummy value already for most GHC API functions. + + The reason the `HomeUnit` used to be optional is to indicate which parts of the GHC API require certain initialisation steps, + such as calling `initUnits` on the `HomeUnitEnv`. The `HomeUnit` is a poor reflection of this requirement, which is why + we decided to make it mandatory whenever there is a `HomeUnitEnv`. + In the future, we might want to reflect this information based on the existence of a `HomeUnitEnv`, which we should only create + if the compiler session actually needs it. +} +mrs: !15885 +issues: #27632 ===================================== 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 @@ -237,16 +238,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 ===================================== @@ -782,14 +782,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 @@ -885,7 +885,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] @@ -1050,12 +1050,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 @@ -1079,13 +1079,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 @@ -1142,13 +1141,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 @@ -1156,7 +1155,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 @@ -1230,7 +1229,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 @@ -1269,7 +1268,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/82b7467cd1a20919bc6c24c1b99b421… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82b7467cd1a20919bc6c24c1b99b421… 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