- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/spj-reinstallable-base] 2 commits: Don't generate $trModule bindings if no type decls!
by Simon Peyton Jones (＠simonpj) 10 Apr '26

10 Apr '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 4d561edf by Simon Peyton Jones at 2026-04-10T11:37:23+01:00 Don't generate $trModule bindings if no type decls! - - - - - e4e62b5e by Simon Peyton Jones at 2026-04-10T17:38:39+01:00 Much progress - - - - - 65 changed files: - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/PrimOps/Ids.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Literals.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Types/Id/Make.hs - compiler/ghc.cabal.in - libraries/base/src/Control/Applicative.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Selected.hs - libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs - libraries/ghc-internal/src/GHC/Internal/ConsoleHandler.hsc - libraries/ghc-internal/src/GHC/Internal/Data/Function.hs - libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/STRef/Strict.hs - libraries/ghc-internal/src/GHC/Internal/Data/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Event.hs - libraries/ghc-internal/src/GHC/Internal/Event/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Concurrent.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/ForeignPtr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/ForeignPtr/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Safe.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/StablePtr.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/IO/StdHandles.hs - libraries/ghc-internal/src/GHC/Internal/Integer/Logarithms.hs - libraries/ghc-internal/src/GHC/Internal/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Numeric/Natural.hs - libraries/ghc-internal/src/GHC/Internal/ST.hs - libraries/ghc-internal/src/GHC/Internal/System/Mem/StableName.hs - libraries/ghc-internal/src/GHC/Internal/Text/Show.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e57ac81fac2952505c0056669ae0d7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e57ac81fac2952505c0056669ae0d7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-26953] Apply 1 suggestion(s) to 1 file(s)
by recursion-ninja (＠recursion-ninja) 10 Apr '26

10 Apr '26

recursion-ninja pushed to branch wip/fix-26953 at Glasgow Haskell Compiler / GHC Commits: 40212ba6 by recursion-ninja at 2026-04-10T16:38:59+00:00 Apply 1 suggestion(s) to 1 file(s) Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com> - - - - - 1 changed file: - compiler/GHC/Hs/Lit.hs Changes: ===================================== compiler/GHC/Hs/Lit.hs ===================================== @@ -603,9 +603,6 @@ rnFractionalLit = convertFractionalLit -- | -- Change the GHC pass from the current 'Pass' to the 'Typechecked' pass. --- This function can safely accept any GHC 'Pass; as the input, --- because 'Typechecked' is the final 'Pass'. Note that this permits the --- "no-op" of going from 'Typechecked' to 'Typechecked'. {-# INLINE[1] tcFractionalLit #-} {-# RULES "tcFractionalLit/id" tcFractionalLit = id #-} tcFractionalLit :: FractionalLit (GhcPass p) -> FractionalLit GhcTc View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40212ba6a3a5661e048b7fbd5f7fa0b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40212ba6a3a5661e048b7fbd5f7fa0b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] Test works on windows
by Hannes Siebenhandl (＠fendor) 10 Apr '26

10 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 0d9ed50c by fendor at 2026-04-10T18:25:01+02:00 Test works on windows - - - - - 1 changed file: - testsuite/tests/hpc/all.T Changes: ===================================== testsuite/tests/hpc/all.T ===================================== @@ -25,7 +25,7 @@ test('T2991', [cmd_wrapper(T2991)], test('T17073a', [when(opsys('mingw32'), expect_broken(17607)), extra_files(['T17073.hs'])], makefile_test, ['T17073a HPC={hpc}']) -test('T17073b', [when(opsys('mingw32'), expect_broken(17607)), extra_files(['T17073.hs'])], +test('T17073b', [extra_files(['T17073.hs'])], makefile_test, ['T17073b HPC={hpc}']) test('T20568a', [extra_files(['T20568.hs'])], makefile_test, []) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0d9ed50c21fb45cbdb9a2f73dbd9805… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0d9ed50c21fb45cbdb9a2f73dbd9805… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T22637-v2
by Simon Jakobi (＠sjakobi2) 10 Apr '26

10 Apr '26

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

1 0

[Git][ghc/ghc][wip/fendor/homeunit-is-just] 2 commits: WIP: always have a home unit
by Hannes Siebenhandl (＠fendor) 10 Apr '26

10 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC Commits: 4199d6a6 by fendor at 2026-04-10T15:14:33+02:00 WIP: always have a home unit - - - - - f5888de7 by fendor at 2026-04-10T15:14:33+02:00 Use proper initialisation instead of hardcoding the unit - - - - - 18 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session/Units.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/Monad.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Home.hs - compiler/GHC/Unit/Home/Graph.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -677,7 +677,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do { homeUnitEnv_units = unit_state , homeUnitEnv_unit_dbs = Just dbs , 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) @@ -768,7 +768,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , homeUnitEnv_unit_dbs = Just dbs , 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 @@ -892,7 +892,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , homeUnitEnv_unit_dbs = Just dbs , 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 @@ -1691,7 +1691,7 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name pkgqual case res of - Found loc m | notHomeModuleMaybe mhome_unit m -> return m + Found loc m | notHomeModule mhome_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -459,7 +459,7 @@ addUnit u = do , ue_home_unit_graph = HUG.unitEnv_singleton (homeUnitId home_unit) - (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) + (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (home_unit)) , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -117,7 +117,7 @@ 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 :: HscEnv -> HomeUnit hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState @@ -374,7 +374,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.hs ===================================== @@ -38,6 +38,7 @@ module GHC.Driver.Main newHscEnv , newHscEnvWithHUG , initHscEnv + , createHomeUnitEnvFromFlags -- * Compiling complete source files , Messager, batchMsg, batchMultiMsg @@ -298,6 +299,7 @@ import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable import qualified GHC.ByteCode.Serialize as ByteCode +import qualified Data.Set as Set {- ********************************************************************** %* * @@ -307,18 +309,15 @@ import qualified GHC.ByteCode.Serialize as ByteCode newHscEnv :: FilePath -> DynFlags -> IO HscEnv newHscEnv top_dir dflags = do - hpt <- emptyHomePackageTable - newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt) - where - home_unit_graph hpt = HUG.unitEnv_singleton - (homeUnitId_ dflags) - (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing) + logger <- initLogger + -- TODO: doesn't quite work, we call 'initUnits' in 'createHomeUnitEnvFromFlags' + (home_unit_graph, mainUnitId) <- createHomeUnitEnvFromFlags logger (NE.singleton dflags) + newHscEnvWithHUG logger top_dir dflags mainUnitId home_unit_graph -newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv -newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do +newHscEnvWithHUG :: Logger -> FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv +newHscEnvWithHUG logger top_dir top_dynflags cur_unit home_unit_graph = do nc_var <- newNameCache fc_var <- initFinderCache - logger <- initLogger tmpfs <- initTmpFs let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup cur_unit home_unit_graph unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) @@ -338,6 +337,24 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do , hsc_llvm_config = llvm_config } +createHomeUnitEnvFromFlags :: Logger -> NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) +createHomeUnitEnvFromFlags logger unitDflags = do + let home_units = Set.fromList (NE.toList $ NE.map homeUnitId_ unitDflags) + + homeUnitEnvs <- forM (NE.toList unitDflags) $ \dflags -> do + let cached_unit_dbs = Nothing + hue_flags = dflags + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger hue_flags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + hpt <- liftIO emptyHomePackageTable + pure (homeUnitId home_unit, HUG.mkHomeUnitEnv unit_state (Just dbs) updated_dflags hpt home_unit) + + let activeUnit = homeUnitId_ $ NE.head unitDflags + let home_unit_graph = HUG.hugFromList homeUnitEnvs + return (home_unit_graph, activeUnit) + -- | Initialize HscEnv from an optional top_dir path initHscEnv :: Maybe FilePath -> IO HscEnv initHscEnv mb_top_dir = do ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -473,7 +473,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (case home_unit of - Just hu + hu | isHomeUnitId hu ghcInternalUnitId , platformOS platform == OSMinGW32 -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"] ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -17,10 +17,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Unit.Env import GHC.Unit (UnitId) -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 import GHC.Types.SourceError @@ -42,6 +39,7 @@ import GHC.ResponseFile (expandResponse) import Data.Bifunctor import GHC.Data.Graph.Directed import qualified Data.List.NonEmpty as NE +import GHC.Driver.Main (createHomeUnitEnvFromFlags) -- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. removeRTS :: [String] -> [String] @@ -125,24 +123,7 @@ 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 - - home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do - let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv - hue_flags = homeUnitEnv_dflags homeUnitEnv - dflags = homeUnitEnv_dflags homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units - - updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants - emptyHpt <- liftIO $ emptyHomePackageTable - pure $ HomeUnitEnv - { homeUnitEnv_units = unit_state - , homeUnitEnv_unit_dbs = Just dbs - , homeUnitEnv_dflags = updated_dflags - , homeUnitEnv_hpt = emptyHpt - , homeUnitEnv_home_unit = Just home_unit - } + (home_unit_graph, mainUnitId) <- liftIO $ createHomeUnitEnvFromFlags logger unitDflags checkUnitCycles initial_dflags home_unit_graph @@ -232,16 +213,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 Nothing dflags emptyHpt Nothing - return (homeUnitId_ dflags, newInternalUnitEnv) - let activeUnit = fst $ NE.head unitEnvList - return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) - - ===================================== compiler/GHC/Iface/Errors.hs ===================================== @@ -27,7 +27,7 @@ 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 = CantFindErr us FindingInterface $ @@ -35,7 +35,7 @@ cannotFindInterface us mhu p mn ifr = cantFindInstalledErr :: UnitState - -> Maybe HomeUnit + -> HomeUnit -> Profile -> ModuleName -> InstalledFindResult @@ -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 mhome_unit pkg) -> not_found_in_package pkg $ fmap unsafeDecodeUtf files | null files @@ -111,11 +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 + , home_unit <- mhome_unit -- there is a home-unit but the , not (isHomeUnit home_unit pkg) -- module isn't from it -> not_found_in_package (toUnitId pkg) files ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -711,12 +711,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 :: HomeUnit -> ModIface -> Bool is_external_sig mhome_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 mhome_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 @@ -745,7 +745,7 @@ computeInterface hsc_env doc_str hi_boot_file mod0 = do m mod0 hi_boot_file case getModuleInstantiation mod0 of (imod, Just indef) - | Just home_unit <- mhome_unit + | home_unit <- mhome_unit , isHomeUnitIndefinite home_unit -> find_iface imod >>= \case Succeeded (iface0, path) -> @@ -803,13 +803,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 = case from of ImportByUser usr_boot - | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod + | usr_boot == IsBoot && notHomeModule mhome_unit mod -> Failed (BadSourceImport mod) | otherwise -> Succeeded usr_boot @@ -817,7 +817,7 @@ wantHiBootFile mhome_unit eps mod from -> Succeeded NotBoot ImportBySystem - | notHomeModuleMaybe mhome_unit mod + | notHomeModule mhome_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 ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -163,8 +163,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = 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 + home_unit -> do let fc = ldFinderCache opts let fopts = ldFinderOpts opts ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -452,7 +452,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 ===================================== @@ -489,8 +489,7 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache -- 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 + home_unit -> do mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) case mb_stuff of Found loc mod -> found loc mod ===================================== compiler/GHC/Tc/Utils/Backpack.hs ===================================== @@ -285,7 +285,7 @@ implicitRequirements hsc_env normal_imports forM normal_imports $ \(mb_pkg, L _ imp) -> do found <- findImportedModule hsc_env imp mb_pkg case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule mhome_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where @@ -307,7 +307,7 @@ implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports go (accL, accR) ((_stage, mb_pkg, L _ imp):imports) = do found <- findImportedModule hsc_env imp mb_pkg let acc' = case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule mhome_unit mod -> case moduleUnit mod of HoleUnit -> (moduleName mod : accL, accR) RealUnit _ -> (accL, accR) ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -2406,7 +2406,7 @@ initIfaceTcRn thing_inside !knot_vars = tcg_type_env_var 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 mhome_unit) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", if_rec_types = ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -214,14 +214,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, + 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) + | isHomeUnitIndefinite home_unit = [] + | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) pkg_map = unitInfoMap unit_state preload = preloadUnits unit_state @@ -302,20 +301,18 @@ 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_unsafeHomeUnit ue = ue_homeUnit ue 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 ===================================== @@ -195,33 +195,29 @@ findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv - -> Maybe HomeUnit + -> HomeUnit -> ModuleName -> PkgQual -> IO FindResult findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import - ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import + ThisPkg uid | (homeUnitId mhome_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 <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where - all_opts = case mhome_unit of - Nothing -> other_fopts - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + all_opts = (homeUnitId mhome_unit, fopts) : other_fopts - home_import = case mhome_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 mhome_unit mod_name home_pkg_import (uid, opts) -- If the module is reexported, then look for it as if it was from the perspective -- of that package which reexports it. | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue (DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual | elementOfUniqSet mod_name (finder_hiddenModules opts) = return (mkHomeHidden uid) | otherwise = @@ -238,9 +234,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = `orIfNotFound` findExposedPackageModule fc fopts units mod_name NoPkgQual - units = case mhome_unit of - Nothing -> ue_homeUnitState ue - Just home_unit -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue + units = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId mhome_unit) ue hpt_deps :: [UnitId] hpt_deps = Set.toList (homeUnitDepends units) other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps @@ -249,13 +243,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified. -findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModuleNoHsc fc fopts units (Just home_unit) mod_name = +findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> ModuleName -> IO FindResult +findPluginModuleNoHsc fc fopts units home_unit mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` findExposedPluginPackageModule fc fopts units mod_name -findPluginModuleNoHsc fc fopts units Nothing mod_name = - findExposedPluginPackageModule fc fopts units mod_name findPluginModule :: HscEnv -> ModuleName -> IO FindResult findPluginModule hsc_env mod_name = do @@ -267,15 +259,15 @@ findPluginModule hsc_env mod_name = do -- | 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 :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do res <- case mhome_unit of - Just home_unit + home_unit | 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 ===================================== compiler/GHC/Unit/Home.hs ===================================== @@ -211,9 +211,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 ===================================== @@ -160,11 +160,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 -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv +mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> HomeUnit -> HomeUnitEnv mkHomeUnitEnv us dbs dflags hpt home_unit = HomeUnitEnv { homeUnitEnv_units = us , homeUnitEnv_unit_dbs = dbs @@ -383,6 +383,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 ===================================== @@ -737,7 +737,7 @@ installInteractiveHomeUnits = do [ sessionUnitExposedFlag ] ++ [ homeUnitPkgFlag uid | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env - , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv] + , let homeUnit = homeUnitEnv_home_unit homeUnitEnv , let uid = homeUnitId homeUnit ] ++ (packageFlags dflags0) @@ -753,7 +753,7 @@ installInteractiveHomeUnits = do { packageFlags = [ homeUnitPkgFlag uid | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env - , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv] + , let homeUnit = homeUnitEnv_home_unit homeUnitEnv , let uid = homeUnitId homeUnit ] ++ (packageFlags dflags) @@ -801,7 +801,7 @@ installInteractiveHomeUnits = do (dbs,unit_state,home_unit,_mconstants) <- liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units hpt <- liftIO emptyHomePackageTable - pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit)) + pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt home_unit) reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13c8c0d1897458653227a8391a8aad… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13c8c0d1897458653227a8391a8aad… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/10.1] 7 commits: Release notes for GHC 10.0
by Zubin (＠wz1000) 10 Apr '26

10 Apr '26

Zubin pushed to branch wip/10.1 at Glasgow Haskell Compiler / GHC Commits: e0ab606d by Zubin Duggal at 2026-04-10T18:40:20+05:30 Release notes for GHC 10.0 - - - - - e08b9b34 by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump ghc-prim version to 0.14.0 - - - - - a92aac6e by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump template-haskell to 2.25.0.0; update submodule exceptions for TH 2.25 - - - - - f254d9e8 by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump GHC version to 10.0 - - - - - 6ce0368a by Zubin Duggal at 2026-04-10T18:40:28+05:30 Bump base to 4.23.0.0; update submodules for base 4.24 upper bound - - - - - 702fb8a5 by Zubin Duggal at 2026-04-10T18:40:28+05:30 Bump GHC version to 10.1; update submodules template-haskell-lift and template-haskell-quasiquoter for ghc-internal 10.200 - - - - - 75df1ca4 by Zubin Duggal at 2026-04-10T18:40:28+05:30 Use changelog.d for release notes (#26002) GHC now uses a fragment-based changelog workflow using a custom script adapted from https://codeberg.org/fgaz/changelog-d. Contributors add a file in changelog.d/ for each user-facing change. At release time, these are assembled into release notes for sphinx (in RST) format, using the tool. New hadrian `changelog` target to generate changelogs CI job to validate changelog entries for MRs unless skipped with ~"no-changelog" label Teach sphinx about ghc-mr: extlink to link to MRs Remove `ghc-package-list` from sphinx, and implement it in changelog-d instead (Fixes #26476). (cherry picked from commit 989c07249978f418dfde1353abfad453f024d61a) - - - - - 64 changed files: - .gitlab-ci.yml - .gitlab/issue_templates/release_tracking.md - .gitlab/merge_request_templates/Default.md - + changelog.d/changelog-entries - + changelog.d/config - compiler/ghc.cabal.in - configure.ac - − docs/users_guide/10.0.1-notes.rst - + docs/users_guide/10.2.1-notes.rst - − docs/users_guide/9.16.1-notes.rst - docs/users_guide/conf.py - docs/users_guide/ghc_config.py.in - − docs/users_guide/ghc_packages.py - docs/users_guide/release-notes.rst - ghc/ghc-bin.cabal.in - hadrian/hadrian.cabal - hadrian/src/CommandLine.hs - hadrian/src/Main.hs - hadrian/src/Packages.hs - + hadrian/src/Rules/Changelog.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Default.hs - libraries/array - libraries/base/base.cabal.in - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/filepath - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-compact/ghc-compact.cabal - libraries/ghc-experimental/ghc-experimental.cabal.in - libraries/ghc-prim/changelog.md - libraries/ghc-prim/ghc-prim.cabal - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/template-haskell-lift - libraries/template-haskell-quasiquoter - libraries/template-haskell/template-haskell.cabal.in - libraries/terminfo - libraries/unix - m4/fp_setup_project_version.m4 - m4/fptools_ghc_version.m4 - testsuite/mk/boilerplate.mk - testsuite/tests/linters/Makefile - testsuite/tests/linters/all.T - + testsuite/tests/linters/changelog-d.stdout - + utils/changelog-d/ChangelogD.hs - + utils/changelog-d/LICENSE - + utils/changelog-d/README.md - + utils/changelog-d/changelog-d.cabal - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/haddock-test/haddock-test.cabal - utils/haddock/haddock.cabal - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0ea1e1fd0709f47239a3c0d8e5e09b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0ea1e1fd0709f47239a3c0d8e5e09b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/homeunit-is-just] Use proper initialisation instead of hardcoding the unit
by Hannes Siebenhandl (＠fendor) 10 Apr '26

10 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC Commits: 13c8c0d1 by fendor at 2026-04-10T14:48:34+02:00 Use proper initialisation instead of hardcoding the unit - - - - - 2 changed files: - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session/Units.hs Changes: ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -38,6 +38,7 @@ module GHC.Driver.Main newHscEnv , newHscEnvWithHUG , initHscEnv + , createHomeUnitEnvFromFlags -- * Compiling complete source files , Messager, batchMsg, batchMultiMsg @@ -298,6 +299,7 @@ import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable import qualified GHC.ByteCode.Serialize as ByteCode +import qualified Data.Set as Set {- ********************************************************************** %* * @@ -307,19 +309,15 @@ import qualified GHC.ByteCode.Serialize as ByteCode newHscEnv :: FilePath -> DynFlags -> IO HscEnv newHscEnv top_dir dflags = do - hpt <- emptyHomePackageTable - newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt) - where - home_unit_graph hpt = - HUG.unitEnv_singleton - (homeUnitId_ dflags) - (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing)) + logger <- initLogger + -- TODO: doesn't quite work, we call 'initUnits' in 'createHomeUnitEnvFromFlags' + (home_unit_graph, mainUnitId) <- createHomeUnitEnvFromFlags logger (NE.singleton dflags) + newHscEnvWithHUG logger top_dir dflags mainUnitId home_unit_graph -newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv -newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do +newHscEnvWithHUG :: Logger -> FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv +newHscEnvWithHUG logger top_dir top_dynflags cur_unit home_unit_graph = do nc_var <- newNameCache fc_var <- initFinderCache - logger <- initLogger tmpfs <- initTmpFs let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup cur_unit home_unit_graph unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) @@ -339,6 +337,24 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do , hsc_llvm_config = llvm_config } +createHomeUnitEnvFromFlags :: Logger -> NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) +createHomeUnitEnvFromFlags logger unitDflags = do + let home_units = Set.fromList (NE.toList $ NE.map homeUnitId_ unitDflags) + + homeUnitEnvs <- forM (NE.toList unitDflags) $ \dflags -> do + let cached_unit_dbs = Nothing + hue_flags = dflags + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger hue_flags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + hpt <- liftIO emptyHomePackageTable + pure (homeUnitId home_unit, HUG.mkHomeUnitEnv unit_state (Just dbs) updated_dflags hpt home_unit) + + let activeUnit = homeUnitId_ $ NE.head unitDflags + let home_unit_graph = HUG.hugFromList homeUnitEnvs + return (home_unit_graph, activeUnit) + -- | Initialize HscEnv from an optional top_dir path initHscEnv :: Maybe FilePath -> IO HscEnv initHscEnv mb_top_dir = do ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -17,11 +17,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Unit.Env import GHC.Unit (UnitId) -import GHC.Unit.Home (GenHomeUnit(..)) -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 import GHC.Types.SourceError @@ -43,6 +39,7 @@ import GHC.ResponseFile (expandResponse) import Data.Bifunctor import GHC.Data.Graph.Directed import qualified Data.List.NonEmpty as NE +import GHC.Driver.Main (createHomeUnitEnvFromFlags) -- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. removeRTS :: [String] -> [String] @@ -126,24 +123,7 @@ 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 - - home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do - let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv - hue_flags = homeUnitEnv_dflags homeUnitEnv - dflags = homeUnitEnv_dflags homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units - - updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants - emptyHpt <- liftIO $ emptyHomePackageTable - pure $ HomeUnitEnv - { homeUnitEnv_units = unit_state - , homeUnitEnv_unit_dbs = Just dbs - , homeUnitEnv_dflags = updated_dflags - , homeUnitEnv_hpt = emptyHpt - , homeUnitEnv_home_unit = home_unit - } + (home_unit_graph, mainUnitId) <- liftIO $ createHomeUnitEnvFromFlags logger unitDflags checkUnitCycles initial_dflags home_unit_graph @@ -233,14 +213,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 Nothing dflags emptyHpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing) - return (homeUnitId_ dflags, newInternalUnitEnv) - let activeUnit = fst $ NE.head unitEnvList - return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13c8c0d1897458653227a8391a8aad8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13c8c0d1897458653227a8391a8aad8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] Add more tests for ghci and -fhpc
by Hannes Siebenhandl (＠fendor) 10 Apr '26

10 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 7f2d3236 by fendor at 2026-04-10T14:24:13+02:00 Add more tests for ghci and -fhpc - - - - - 23 changed files: - testsuite/tests/hpc/Makefile - testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout - + testsuite/tests/hpc/T17073b.stdout - testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout - + testsuite/tests/hpc/T20568b.stdout - testsuite/tests/hpc/all.T - testsuite/tests/hpc/fork/Makefile - testsuite/tests/hpc/function/Makefile - testsuite/tests/hpc/function/test.T - + testsuite/tests/hpc/function/tough1.stderr - + testsuite/tests/hpc/function/tough1.stdout - testsuite/tests/hpc/function2/test.T - + testsuite/tests/hpc/function2/tough3.script - testsuite/tests/hpc/ghc_ghci/Makefile - testsuite/tests/hpc/hpcrun.pl - testsuite/tests/hpc/simple/Makefile - + testsuite/tests/hpc/simple/hpc002.hs - + testsuite/tests/hpc/simple/hpc002.stdout - + testsuite/tests/hpc/simple/hpc003.hs - + testsuite/tests/hpc/simple/hpc003.script - + testsuite/tests/hpc/simple/hpc003.stderr - + testsuite/tests/hpc/simple/hpc003.stdout - testsuite/tests/hpc/simple/test.T Changes: ===================================== testsuite/tests/hpc/Makefile ===================================== @@ -1,4 +1,4 @@ -TOP=../.. +TOP=/home/hugin/Documents/haskell/ghc-hpc-bc/testsuite include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk @@ -8,13 +8,22 @@ T11798: "$(TEST_HC)" $(TEST_HC_ARGS) T11798 -fhpc test -e .hpc/T11798.mix -T17073: +T17073a: LANG=ASCII "$(TEST_HC)" $(TEST_HC_ARGS) T17073.hs -fhpc -v0 ./T17073 "$(HPC)" report T17073 "$(HPC)" version LANG=ASCII "$(HPC)" markup T17073 -T20568: +T17073b: + HPCTIXFILE=ghc.tix "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) $(TEST_HC_ARGS) T17073.hs -fhpc -v0 -e ":main" + "$(HPC)" report ghc + "$(HPC)" version + LANG=ASCII "$(HPC)" markup ghc + +T20568a: "$(TEST_HC)" $(TEST_HC_ARGS) T20568.hs -fhpc -v0 ./T20568 + +T20568b: + HPCTIXFILE=ghc.tix "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) $(TEST_HC_ARGS) T20568.hs -fhpc -v0 -e ":main" ===================================== testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout ===================================== @@ -12,4 +12,4 @@ Writing: Main.hs.html Writing: hpc_index.html Writing: hpc_index_fun.html Writing: hpc_index_alt.html -Writing: hpc_index_exp.html \ No newline at end of file +Writing: hpc_index_exp.html ===================================== testsuite/tests/hpc/T17073b.stdout ===================================== @@ -0,0 +1,15 @@ +Добрый день +100% expressions used (2/2) +100% boolean coverage (0/0) + 100% guards (0/0) + 100% 'if' conditions (0/0) + 100% qualifiers (0/0) +100% alternatives used (0/0) +100% local declarations used (0/0) +100% top-level declarations used (1/1) +hpc tools, version 0.69 +Writing: Main.hs.html +Writing: hpc_index.html +Writing: hpc_index_fun.html +Writing: hpc_index_alt.html +Writing: hpc_index_exp.html ===================================== testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout ===================================== ===================================== testsuite/tests/hpc/T20568b.stdout ===================================== @@ -0,0 +1 @@ +IfThenElse (AstBool True) (AstInt 1) (AstInt 2) ===================================== testsuite/tests/hpc/all.T ===================================== @@ -23,7 +23,10 @@ test('T2991', [cmd_wrapper(T2991)], # Run with 'ghc --main'. Do not list other modules explicitly. multimod_compile_and_run, ['T2991', '']) -test('T17073', when(opsys('mingw32'), expect_broken(17607)), - makefile_test, ['T17073 HPC={hpc}']) +test('T17073a', [when(opsys('mingw32'), expect_broken(17607)), extra_files(['T17073.hs'])], + makefile_test, ['T17073a HPC={hpc}']) +test('T17073b', [when(opsys('mingw32'), expect_broken(17607)), extra_files(['T17073.hs'])], + makefile_test, ['T17073b HPC={hpc}']) -test('T20568', normal, makefile_test, []) +test('T20568a', [extra_files(['T20568.hs'])], makefile_test, []) +test('T20568b', [extra_files(['T20568.hs'])], makefile_test, []) ===================================== testsuite/tests/hpc/fork/Makefile ===================================== @@ -1,4 +1,3 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk - ===================================== testsuite/tests/hpc/function/Makefile ===================================== @@ -2,3 +2,8 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk +tough1: + HPCTIXFILE=ghc.tix "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTICE) -v0 -fhpc tough.hs -e "main" + "$(HPC)" report ghc.tix + "$(HPC)" report ghc.tix --per-module + "$(HPC)" markup ghc.tix ===================================== testsuite/tests/hpc/function/test.T ===================================== @@ -1,4 +1,4 @@ -setTestOpts([omit_ghci, when(fast(), skip), js_skip]) +setTestOpts([when(fast(), skip), js_skip]) hpc_prefix = "perl hpcrun.pl --clear --exeext={exeext} --hpc={hpc}" @@ -8,3 +8,9 @@ test('tough', ignore_extension, when(arch('wasm32'), fragile(23243))], compile_and_run, ['-fhpc']) + +test('tough1', + [extra_files(['tough.hs']), + ignore_extension, + when(arch('wasm32'), fragile(23243))], + makefile_test, []) ===================================== testsuite/tests/hpc/function/tough1.stderr ===================================== @@ -0,0 +1,7 @@ +tough.hs:22:5: warning: [GHC-53633] [-Woverlapping-patterns] + Pattern match is redundant + In a case alternative: _ -> ... + | +22 | _ -> error "Bad Thing Happened" + | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ===================================== testsuite/tests/hpc/function/tough1.stdout ===================================== @@ -0,0 +1,29 @@ +"Hello" +"Hello" +badCase +badCase +"Bark" +"Hello" +(1,2,3) + 73% expressions used (73/100) + 14% boolean coverage (1/7) + 0% guards (0/4), 3 always True, 1 always False + 33% 'if' conditions (1/3), 1 always True, 1 always False + 100% qualifiers (0/0) + 58% alternatives used (7/12) +100% local declarations used (0/0) + 83% top-level declarations used (5/6) +-----<module Main>----- + 73% expressions used (73/100) + 14% boolean coverage (1/7) + 0% guards (0/4), 3 always True, 1 always False + 33% 'if' conditions (1/3), 1 always True, 1 always False + 100% qualifiers (0/0) + 58% alternatives used (7/12) +100% local declarations used (0/0) + 83% top-level declarations used (5/6) +Writing: Main.hs.html +Writing: hpc_index.html +Writing: hpc_index_fun.html +Writing: hpc_index_alt.html +Writing: hpc_index_exp.html ===================================== testsuite/tests/hpc/function2/test.T ===================================== @@ -14,3 +14,14 @@ test('tough2', omit_ways(ghci_ways + prof_ways), # profile goes in the wrong place when(arch('wasm32'), fragile(23243)) ], multimod_compile_and_run, ['subdir/tough2.lhs', '-fhpc']) + +# Same as tough2, but for ghci +test('tough3', + [extra_files(['../hpcrun.pl', 'subdir/']), + literate, + cmd_prefix(hpc_prefix), + ignore_extension, + extra_hc_opts('-fhpc subdir/tough2.lhs'), + omit_ways(ghci_ways + prof_ways), # profile goes in the wrong place + when(arch('wasm32'), fragile(23243)) ], + ghci_script, ['tough3.script']) ===================================== testsuite/tests/hpc/function2/tough3.script ===================================== @@ -0,0 +1,2 @@ +:main +:quit ===================================== testsuite/tests/hpc/ghc_ghci/Makefile ===================================== @@ -9,7 +9,7 @@ hpc_ghc_ghci: hpc_ghc_ghci_bytecode: rm -f ./*.tix - printf "main\n:quit\n" | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -fhpc -fbyte-code-and-object-code -fprefer-byte-code BytecodeMain.hs + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -fhpc -fbyte-code-and-object-code -fprefer-byte-code BytecodeMain.hs -e "main" -e ":quit" @[ -f .hpc/Main.mix ] || (echo "ERROR: Expected .hpc/Main.mix file not found"; exit 1) @set -- ./*.tix; [ -f "$$1" ] || (echo "ERROR: Expected .tix file not found"; exit 1); '$(HPC)' report "$$1" Main > hpc-report.txt @grep -F "100% expressions used" hpc-report.txt >/dev/null || (echo "ERROR: Expected full expression coverage in hpc report"; cat hpc-report.txt; exit 1) ===================================== testsuite/tests/hpc/hpcrun.pl ===================================== @@ -4,11 +4,12 @@ while($ARGV[0] =~ /^--/) { $arg = shift @ARGV; + last if ($arg eq '--'); if ($arg =~ /--hpc=(.*)/) { $HPC = $1; - } + } elsif ($arg =~ /--clear/) { - $CLEAR = 1; + $CLEAR = 1; } elsif ($arg =~ /--exeext=(.*)/) { $exeext = $1; @@ -19,8 +20,10 @@ while($ARGV[0] =~ /^--/) { } die "no option --hpc=* provided\n" if (!defined($HPC)); - -$binary = $ARGV[0] . $exeext; + +# Skip over any KEY=VALUE env assignments to find the real executable +my $exe = (grep { !/^\w+=/ } @ARGV)[0]; +$binary = $exe . $exeext; # get the basename: needed for the test function/subdir/tough2 $binary =~ s/^.*\/([^\/]*)$/$1/; @@ -38,7 +41,7 @@ while(<MARKUP>) { my $line = $_; print $line; if (/Writing: (\S+.html)/) { - system("cat $1"); + system("cat $1"); } } print "\n\n"; ===================================== testsuite/tests/hpc/simple/Makefile ===================================== @@ -2,3 +2,12 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk +hpc002: + HPCTIXFILE=ghc.tix "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) $(TEST_HC_ARGS) hpc002.hs -fhpc -v0 -e ":main" + "$(HPC)" report ghc + "$(HPC)" report ghc --per-module + LANG=ASCII "$(HPC)" markup ghc + +hpc003: + HPCTIXFILE=ghc.tix "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) $(TEST_HC_ARGS) -fhpc -v0 < hpc003.script + "$(HPC)" report ghc || echo "Can't summarise file that is ':load'ed" ===================================== testsuite/tests/hpc/simple/hpc002.hs ===================================== @@ -0,0 +1 @@ +main = print (const "Hello" "World") ===================================== testsuite/tests/hpc/simple/hpc002.stdout ===================================== @@ -0,0 +1,23 @@ +"Hello" + 75% expressions used (3/4) +100% boolean coverage (0/0) + 100% guards (0/0) + 100% 'if' conditions (0/0) + 100% qualifiers (0/0) +100% alternatives used (0/0) +100% local declarations used (0/0) +100% top-level declarations used (1/1) +-----<module Main>----- + 75% expressions used (3/4) +100% boolean coverage (0/0) + 100% guards (0/0) + 100% 'if' conditions (0/0) + 100% qualifiers (0/0) +100% alternatives used (0/0) +100% local declarations used (0/0) +100% top-level declarations used (1/1) +Writing: Main.hs.html +Writing: hpc_index.html +Writing: hpc_index_fun.html +Writing: hpc_index_alt.html +Writing: hpc_index_exp.html ===================================== testsuite/tests/hpc/simple/hpc003.hs ===================================== @@ -0,0 +1 @@ +main = print (const "Hello" "World") ===================================== testsuite/tests/hpc/simple/hpc003.script ===================================== @@ -0,0 +1,2 @@ +:load hpc003.hs +:main ===================================== testsuite/tests/hpc/simple/hpc003.stderr ===================================== @@ -0,0 +1,7 @@ +hpc: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: + +can not find interactivezmsession_Main in ./.hpc + +HasCallStack backtrace: + error, called at libraries/hpc/Trace/Hpc/Mix.hs:110:15 in hpc-0.7.0.2-inplace:Trace.Hpc.Mix + ===================================== testsuite/tests/hpc/simple/hpc003.stdout ===================================== @@ -0,0 +1,2 @@ +"Hello" +Can't summarise file that is ':load'ed ===================================== testsuite/tests/hpc/simple/test.T ===================================== @@ -1,4 +1,4 @@ -setTestOpts([omit_ghci, when(fast(), skip), js_skip]) +setTestOpts([when(fast(), skip), js_skip]) hpc_prefix = "perl hpcrun.pl --clear --exeext={exeext} --hpc={hpc}" @@ -7,3 +7,16 @@ test('hpc001', [extra_files(['../hpcrun.pl']), cmd_prefix(hpc_prefix), ignore_extension ], compile_and_run, ['-fhpc']) + +test('hpc002', + [ when(arch('wasm32'), fragile(23243)) + , ignore_extension + ], + makefile_test, []) + +test('hpc003', + [ when(arch('wasm32'), fragile(23243)) + , ignore_extension + , extra_files(['hpc003.script']) + ], + makefile_test, []) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f2d3236253adbaa7239832b6ff25f8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f2d3236253adbaa7239832b6ff25f8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/homeunit-is-just] WIP: always have a home unit
by Hannes Siebenhandl (＠fendor) 10 Apr '26

10 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC Commits: 86c05a3f by fendor at 2026-04-10T14:17:04+02:00 WIP: always have a home unit - - - - - 18 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session/Units.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/Monad.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Home.hs - compiler/GHC/Unit/Home/Graph.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -677,7 +677,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do { homeUnitEnv_units = unit_state , homeUnitEnv_unit_dbs = Just dbs , 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) @@ -768,7 +768,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , homeUnitEnv_unit_dbs = Just dbs , 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 @@ -892,7 +892,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , homeUnitEnv_unit_dbs = Just dbs , 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 @@ -1691,7 +1691,7 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name pkgqual case res of - Found loc m | notHomeModuleMaybe mhome_unit m -> return m + Found loc m | notHomeModule mhome_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -459,7 +459,7 @@ addUnit u = do , ue_home_unit_graph = HUG.unitEnv_singleton (homeUnitId home_unit) - (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) + (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (home_unit)) , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -117,7 +117,7 @@ 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 :: HscEnv -> HomeUnit hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState @@ -374,7 +374,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.hs ===================================== @@ -310,9 +310,10 @@ newHscEnv top_dir dflags = do hpt <- emptyHomePackageTable newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt) where - home_unit_graph hpt = HUG.unitEnv_singleton - (homeUnitId_ dflags) - (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing) + home_unit_graph hpt = + HUG.unitEnv_singleton + (homeUnitId_ dflags) + (HUG.mkHomeUnitEnv emptyUnitState Nothing 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/Pipeline/Execute.hs ===================================== @@ -473,7 +473,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (case home_unit of - Just hu + hu | isHomeUnitId hu ghcInternalUnitId , platformOS platform == OSMinGW32 -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"] ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -17,6 +17,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Unit.Env import GHC.Unit (UnitId) +import GHC.Unit.Home (GenHomeUnit(..)) import GHC.Unit.Home.PackageTable import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.State ( emptyUnitState ) @@ -141,7 +142,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do , homeUnitEnv_unit_dbs = Just dbs , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = emptyHpt - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } checkUnitCycles initial_dflags home_unit_graph @@ -239,9 +240,7 @@ createUnitEnvFromFlags unitDflags = do unitEnvList <- forM unitDflags $ \dflags -> do emptyHpt <- emptyHomePackageTable let newInternalUnitEnv = - HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing + HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing) return (homeUnitId_ dflags, newInternalUnitEnv) let activeUnit = fst $ NE.head unitEnvList return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) - - ===================================== compiler/GHC/Iface/Errors.hs ===================================== @@ -27,7 +27,7 @@ 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 = CantFindErr us FindingInterface $ @@ -35,7 +35,7 @@ cannotFindInterface us mhu p mn ifr = cantFindInstalledErr :: UnitState - -> Maybe HomeUnit + -> HomeUnit -> Profile -> ModuleName -> InstalledFindResult @@ -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 mhome_unit pkg) -> not_found_in_package pkg $ fmap unsafeDecodeUtf files | null files @@ -111,11 +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 + , home_unit <- mhome_unit -- there is a home-unit but the , not (isHomeUnit home_unit pkg) -- module isn't from it -> not_found_in_package (toUnitId pkg) files ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -711,12 +711,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 :: HomeUnit -> ModIface -> Bool is_external_sig mhome_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 mhome_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 @@ -745,7 +745,7 @@ computeInterface hsc_env doc_str hi_boot_file mod0 = do m mod0 hi_boot_file case getModuleInstantiation mod0 of (imod, Just indef) - | Just home_unit <- mhome_unit + | home_unit <- mhome_unit , isHomeUnitIndefinite home_unit -> find_iface imod >>= \case Succeeded (iface0, path) -> @@ -803,13 +803,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 = case from of ImportByUser usr_boot - | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod + | usr_boot == IsBoot && notHomeModule mhome_unit mod -> Failed (BadSourceImport mod) | otherwise -> Succeeded usr_boot @@ -817,7 +817,7 @@ wantHiBootFile mhome_unit eps mod from -> Succeeded NotBoot ImportBySystem - | notHomeModuleMaybe mhome_unit mod + | notHomeModule mhome_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 ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -163,8 +163,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = 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 + home_unit -> do let fc = ldFinderCache opts let fopts = ldFinderOpts opts ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -452,7 +452,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 ===================================== @@ -489,8 +489,7 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache -- 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 + home_unit -> do mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) case mb_stuff of Found loc mod -> found loc mod ===================================== compiler/GHC/Tc/Utils/Backpack.hs ===================================== @@ -285,7 +285,7 @@ implicitRequirements hsc_env normal_imports forM normal_imports $ \(mb_pkg, L _ imp) -> do found <- findImportedModule hsc_env imp mb_pkg case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule mhome_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where @@ -307,7 +307,7 @@ implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports go (accL, accR) ((_stage, mb_pkg, L _ imp):imports) = do found <- findImportedModule hsc_env imp mb_pkg let acc' = case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule mhome_unit mod -> case moduleUnit mod of HoleUnit -> (moduleName mod : accL, accR) RealUnit _ -> (accL, accR) ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -2406,7 +2406,7 @@ initIfaceTcRn thing_inside !knot_vars = tcg_type_env_var 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 mhome_unit) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", if_rec_types = ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -214,14 +214,8 @@ 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) + inst_ids = + map (toUnitId . moduleUnit . snd) (homeUnitInstantiations $ ue_homeUnit unit_env) pkg_map = unitInfoMap unit_state preload = preloadUnits unit_state @@ -302,20 +296,18 @@ 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_unsafeHomeUnit ue = ue_homeUnit ue 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 ===================================== @@ -195,33 +195,29 @@ findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv - -> Maybe HomeUnit + -> HomeUnit -> ModuleName -> PkgQual -> IO FindResult findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import - ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import + ThisPkg uid | (homeUnitId mhome_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 <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where - all_opts = case mhome_unit of - Nothing -> other_fopts - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + all_opts = (homeUnitId mhome_unit, fopts) : other_fopts - home_import = case mhome_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 mhome_unit mod_name home_pkg_import (uid, opts) -- If the module is reexported, then look for it as if it was from the perspective -- of that package which reexports it. | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue (DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual | elementOfUniqSet mod_name (finder_hiddenModules opts) = return (mkHomeHidden uid) | otherwise = @@ -238,9 +234,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = `orIfNotFound` findExposedPackageModule fc fopts units mod_name NoPkgQual - units = case mhome_unit of - Nothing -> ue_homeUnitState ue - Just home_unit -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue + units = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId mhome_unit) ue hpt_deps :: [UnitId] hpt_deps = Set.toList (homeUnitDepends units) other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps @@ -249,13 +243,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified. -findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModuleNoHsc fc fopts units (Just home_unit) mod_name = +findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> ModuleName -> IO FindResult +findPluginModuleNoHsc fc fopts units home_unit mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` findExposedPluginPackageModule fc fopts units mod_name -findPluginModuleNoHsc fc fopts units Nothing mod_name = - findExposedPluginPackageModule fc fopts units mod_name findPluginModule :: HscEnv -> ModuleName -> IO FindResult findPluginModule hsc_env mod_name = do @@ -267,15 +259,15 @@ findPluginModule hsc_env mod_name = do -- | 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 :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do res <- case mhome_unit of - Just home_unit + home_unit | 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 ===================================== compiler/GHC/Unit/Home.hs ===================================== @@ -211,9 +211,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 ===================================== @@ -160,11 +160,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 -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv +mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> HomeUnit -> HomeUnitEnv mkHomeUnitEnv us dbs dflags hpt home_unit = HomeUnitEnv { homeUnitEnv_units = us , homeUnitEnv_unit_dbs = dbs @@ -383,6 +383,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 ===================================== @@ -737,7 +737,7 @@ installInteractiveHomeUnits = do [ sessionUnitExposedFlag ] ++ [ homeUnitPkgFlag uid | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env - , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv] + , let homeUnit = homeUnitEnv_home_unit homeUnitEnv , let uid = homeUnitId homeUnit ] ++ (packageFlags dflags0) @@ -753,7 +753,7 @@ installInteractiveHomeUnits = do { packageFlags = [ homeUnitPkgFlag uid | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env - , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv] + , let homeUnit = homeUnitEnv_home_unit homeUnitEnv , let uid = homeUnitId homeUnit ] ++ (packageFlags dflags) @@ -801,7 +801,7 @@ installInteractiveHomeUnits = do (dbs,unit_state,home_unit,_mconstants) <- liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units hpt <- liftIO emptyHomePackageTable - pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit)) + pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt home_unit) reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86c05a3f4072c5aa05230f84b6feb0d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86c05a3f4072c5aa05230f84b6feb0d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/27162/hadrian-linkhs-response-file] Use response files for hadrian linking with ghc.
by David Eichmann (＠DavidEichmann) 10 Apr '26

10 Apr '26

David Eichmann pushed to branch wip/27162/hadrian-linkhs-response-file at Glasgow Haskell Compiler / GHC Commits: 544fabc6 by Duncan Coutts at 2026-04-10T12:50:37+01:00 Use response files for hadrian linking with ghc. In future supoort for windows dynamic linking, we expect long command lines for linking dll files (which use ghc calling (l)ld) rather than ar as is done for static linking). Experiments yielded a link command line for ghc-internal well over 32kb. We did not encounter this before for static libs, since we already use ar's @file feature (if available, which it is for the llvm toolchain). Co-authored-by: David Eichmann <davide(a)well-typed.com> - - - - - 1 changed file: - hadrian/src/Builder.hs Changes: ===================================== hadrian/src/Builder.hs ===================================== @@ -345,12 +345,16 @@ instance H.Builder Builder where Haddock BuildPackage -> runHaddock path buildArgs buildInputs - Ghc FindHsDependencies _ -> do - -- Use a response file for ghc -M invocations, to - -- avoid issues with command line size limit on - -- Windows (#26637) + Ghc FindHsDependencies _ -> + -- We can't put the flags in a response file, because some flags + -- require empty arguments (such as the -dep-suffix flag), but + -- that isn't supported yet due to #26560. runGhcWithResponse path buildArgs buildInputs + Ghc LinkHs _ -> + -- We do not pass `buildInputs` as they are duplicated in `buildArgs` + runGhcWithResponse path [] buildArgs + HsCpp -> captureStdout Make dir -> cmd' buildOptions path ["-C", dir] buildArgs @@ -393,15 +397,18 @@ runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do writeFile' tmp $ escapeArgs fileInputs cmd [haddockPath] flagArgs ('@' : tmp) -runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action () -runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do - - writeFile' tmp $ escapeArgs fileInputs - - -- We can't put the flags in a response file, because some flags - -- require empty arguments (such as the -dep-suffix flag), but - -- that isn't supported yet due to #26560. - cmd [ghcPath] flagArgs ('@' : tmp) +-- | Use a response file for ghc invocations to avoid issues with command line +-- size limit on Windows (#26637). +runGhcWithResponse :: FilePath -- ^ Path to ghc + -> [String] -- ^ Arguments to be passed on the command line + -> [String] -- ^ Arguments to be passed via the response file (cannot contain empty arguemnts) + -> Action () +runGhcWithResponse ghcPath args responseFileArgs = withTempFile $ \tmp -> do + let tmpContents = escapeArgs responseFileArgs + writeFile' tmp tmpContents + when (any null responseFileArgs) (putWarn $ "Response file arguments (" <> tmp <> ") contains empty arguments") + putVerbose $ tmp <> ": " <> tmpContents + cmd [ghcPath] args ('@' : tmp) -- TODO: Some builders are required only on certain platforms. For example, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/544fabc6d153b912e0ce6d44ec1e65a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/544fabc6d153b912e0ce6d44ec1e65a… You're receiving this email because of your account on gitlab.haskell.org.

1 0