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
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
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
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
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
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
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
[Git][ghc/ghc][wip/sjakobi/T10531] 10 commits: Implement modifiers syntax.
by Simon Jakobi (＠sjakobi2) 10 Apr '26
by Simon Jakobi (＠sjakobi2) 10 Apr '26
10 Apr '26
Simon Jakobi pushed to branch wip/sjakobi/T10531 at Glasgow Haskell Compiler / GHC
Commits:
4a122bb6 by Phil Hazelden at 2026-04-08T20:49:42-04:00
Implement modifiers syntax.
The `%m` syntax of linear types is now accepted in more places, to allow
use by future extensions, though so far linear types is still the only
consumer.
This may break existing code where it
* Uses -XLinearTypes.
* Has code of the form `a %m -> b`, where `m` can't be inferred to be
kind Multiplicity.
The code can be fixed either by adding a kind annotation, or by setting
`-XLinearTypes -XNoModifiers`.
Proposal:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0370-m…
- - - - -
07267f79 by Zubin Duggal at 2026-04-08T20:50:25-04:00
hadrian: Don't include the package hash in the haddock directory
Since GHC 9.8 and hash_unit_ids, haddock urls have looked like`ghc-9.10.3/doc/html/libraries/base-4.20.2.0-39f9/**/*.html`
The inclusion of the hash makes it hard for downstream non-boot packages to properly link to these files, as the hash is not
part of a standard cabal substitution.
Since we only build one version of each package, we don't need the hash to disambiguate anything, we can just remove it.
Fixes #26635
- - - - -
0a83b95b by ARATA Mizuki at 2026-04-08T20:51:18-04:00
testsuite: Allow multiple ways to be run by setting multiple command-line options
This patch allows multiple `--test-way`s to take effect, like:
$ hadrian/build test --test-way=normal --test-way=llvm
Previously, only one way was run if the test speed was 'normal' or 'fast'.
Closes #26926
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
e841931c by Teo Camarasu at 2026-04-08T20:52:00-04:00
doc: improve eventlog-flush-interval flag documentation
We mention the performance cost and how this flag can be turned off.
Resolves #27056
- - - - -
e332db25 by Teo Camarasu at 2026-04-08T20:52:01-04:00
docs/user_guide: fix typo
- - - - -
5b82080a by Simon Jakobi at 2026-04-08T20:52:44-04:00
Fix -dsuppress-uniques for free variables in demand signatures
Before: Str=b{sXyZ->S}
With this patch: Str=b{S}
T13143.stderr is updated accordingly.
Fixes #27106.
- - - - -
b7a084cc by Simon Jakobi at 2026-04-08T20:53:27-04:00
Documentation fixes for demand signature notation
Fixes #27115.
- - - - -
59391132 by Simon Jakobi at 2026-04-08T20:54:08-04:00
Use upsert for non-deleting map updates
Some compiler functions were using `alter`, despite never removing
any entries: they only update an existing entry or insert a new one.
These functions are converted to using `upsert`:
alter :: (Maybe a -> Maybe a) -> Key -> Map a -> Map a
upsert :: (Maybe a -> a) -> Key -> Map a -> Map a
`upsert` variants are also added to APIs of the various Word64Map
wrapper types.
The precedent for this `upsert` operation is in the containers library:
see https://github.com/haskell/containers/pull/1145
Metrics: compile_time/bytes allocated
-------------------------------------
geo. mean: -0.1%
minimum: -0.5%
maximum: +0.0%
Resolves #27140.
- - - - -
da7e82f4 by Cheng Shao at 2026-04-08T20:54:49-04:00
testsuite: fix testsuite run for +ipe again
This patch makes the +ipe flavour transformer pass the entire
testsuite again by dropping stdout/stderr checks of certain tests that
are sensitive to stack layout changes with `+ipe`. Related: #26799.
- - - - -
22056fa5 by Simon Jakobi at 2026-04-10T13:12:27+02:00
Add regression test for #10531
Closes #10531.
- - - - -
205 changed files:
- compiler/GHC/Cmm/CommonBlockElim.hs
- compiler/GHC/Cmm/Dataflow/Graph.hs
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/CmmToAsm/CFG.hs
- compiler/GHC/Core/Multiplicity.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/RoughMap.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/TyCon/Env.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Data/FastString/Env.hs
- compiler/GHC/Data/Word64Map/Internal.hs
- compiler/GHC/Data/Word64Map/Lazy.hs
- compiler/GHC/Data/Word64Map/Strict.hs
- compiler/GHC/Data/Word64Map/Strict/Internal.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Default.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Solver/Types.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/Name/Env.hs
- compiler/GHC/Types/Name/Occurrence.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Var/Env.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Decls/Foreign.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- compiler/Language/Haskell/Syntax/Type.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/exts/linear_types.rst
- + docs/users_guide/exts/modifiers.rst
- docs/users_guide/exts/syntax.rst
- docs/users_guide/runtime_control.rst
- docs/users_guide/using-optimisation.rst
- docs/users_guide/using-warnings.rst
- hadrian/bindist/Makefile
- hadrian/src/CommandLine.hs
- hadrian/src/Context.hs
- hadrian/src/Settings/Builders/Cabal.hs
- libraries/ghc-experimental/tests/backtraces/all.T
- libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
- libraries/ghc-internal/tests/stack-annotation/all.T
- testsuite/driver/testlib.py
- testsuite/tests/dmdanal/should_compile/T13143.stderr
- + testsuite/tests/dmdanal/should_compile/T27106.hs
- + testsuite/tests/dmdanal/should_compile/T27106.stderr
- testsuite/tests/dmdanal/should_compile/all.T
- + testsuite/tests/driver/T10531/A.hs
- + testsuite/tests/driver/T10531/B.hs
- + testsuite/tests/driver/T10531/C.hs
- + testsuite/tests/driver/T10531/Makefile
- + testsuite/tests/driver/T10531/all.T
- testsuite/tests/driver/T4437.hs
- testsuite/tests/ghc-api/T25121_status.stdout
- testsuite/tests/ghc-api/exactprint/Test20239.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/haddock/should_compile_flag_haddock/haddockLinear.hs
- testsuite/tests/haddock/should_compile_flag_haddock/haddockLinear.stderr
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/linear/should_compile/Linear1Rule.hs
- testsuite/tests/linear/should_compile/MultConstructor.hs
- testsuite/tests/linear/should_compile/NonLinearRecord.hs
- testsuite/tests/linear/should_compile/OldList.hs
- testsuite/tests/linear/should_compile/T19400.hs
- testsuite/tests/linear/should_compile/T22546.hs
- testsuite/tests/linear/should_compile/T23025.hs
- testsuite/tests/linear/should_compile/T26332.hs
- testsuite/tests/linear/should_fail/LinearErrOrigin.hs
- testsuite/tests/linear/should_fail/LinearErrOrigin.stderr
- testsuite/tests/linear/should_fail/LinearLet10.hs
- testsuite/tests/linear/should_fail/LinearLet10.stderr
- testsuite/tests/linear/should_fail/LinearPartialSig.hs
- testsuite/tests/linear/should_fail/LinearPartialSig.stderr
- testsuite/tests/linear/should_fail/LinearRole.hs
- + testsuite/tests/linear/should_fail/LinearUnknownModifierKind.hs
- + testsuite/tests/linear/should_fail/LinearUnknownModifierKind.stderr
- testsuite/tests/linear/should_fail/LinearVar.hs
- testsuite/tests/linear/should_fail/LinearVar.stderr
- testsuite/tests/linear/should_fail/T18888_datakinds.hs
- testsuite/tests/linear/should_fail/T18888_datakinds.stderr
- testsuite/tests/linear/should_fail/T19361.hs
- testsuite/tests/linear/should_fail/T19361.stderr
- testsuite/tests/linear/should_fail/T20083.hs
- testsuite/tests/linear/should_fail/T20083.stderr
- testsuite/tests/linear/should_fail/T21278.hs
- testsuite/tests/linear/should_fail/T21278.stderr
- + testsuite/tests/linear/should_fail/TooManyMultiplicities.hs
- + testsuite/tests/linear/should_fail/TooManyMultiplicities.stderr
- + testsuite/tests/linear/should_fail/TooManyMultiplicitiesU.hs
- + testsuite/tests/linear/should_fail/TooManyMultiplicitiesU.stderr
- testsuite/tests/linear/should_fail/all.T
- + testsuite/tests/modifiers/Makefile
- + testsuite/tests/modifiers/should_compile/LinearNoModifiers.hs
- + testsuite/tests/modifiers/should_compile/Makefile
- + testsuite/tests/modifiers/should_compile/Modifier1Linear.hs
- + testsuite/tests/modifiers/should_compile/Modifier1Linear.stderr
- + testsuite/tests/modifiers/should_compile/Modifiers.hs
- + testsuite/tests/modifiers/should_compile/Modifiers.stderr
- + testsuite/tests/modifiers/should_compile/ModifiersSuggestLinear.hs
- + testsuite/tests/modifiers/should_compile/ModifiersSuggestLinear.stderr
- + testsuite/tests/modifiers/should_compile/all.T
- + testsuite/tests/modifiers/should_fail/Makefile
- + testsuite/tests/modifiers/should_fail/ModifiersExprUnexpectedInQuote.hs
- + testsuite/tests/modifiers/should_fail/ModifiersExprUnexpectedInQuote.stderr
- + testsuite/tests/modifiers/should_fail/ModifiersForbiddenHere.hs
- + testsuite/tests/modifiers/should_fail/ModifiersForbiddenHere.stderr
- + testsuite/tests/modifiers/should_fail/ModifiersNoExt.hs
- + testsuite/tests/modifiers/should_fail/ModifiersNoExt.stderr
- + testsuite/tests/modifiers/should_fail/ModifiersUnexpectedInQuote.hs
- + testsuite/tests/modifiers/should_fail/ModifiersUnexpectedInQuote.stderr
- + testsuite/tests/modifiers/should_fail/ModifiersUnknownKind.hs
- + testsuite/tests/modifiers/should_fail/ModifiersUnknownKind.stderr
- + testsuite/tests/modifiers/should_fail/all.T
- testsuite/tests/parser/should_compile/DumpParsedAst.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/T18834a.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/parser/should_fail/T19928.stderr
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/PprModifiers.hs
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20315.hs
- testsuite/tests/printer/Test20315.stderr
- testsuite/tests/printer/Test24533.stdout
- testsuite/tests/printer/all.T
- testsuite/tests/rename/should_compile/T22478a.hs
- testsuite/tests/typecheck/no_skolem_info/T20232.hs
- testsuite/tests/typecheck/no_skolem_info/T20232.stderr
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
- utils/haddock/html-test/src/LinearTypes.hs
- utils/haddock/latex-test/src/LinearTypes/LinearTypes.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a7aa147b8eff68f9982e0676d533d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a7aa147b8eff68f9982e0676d533d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/27162/hadrian-linkhs-response-file
by David Eichmann (＠DavidEichmann) 10 Apr '26
by David Eichmann (＠DavidEichmann) 10 Apr '26
10 Apr '26
David Eichmann pushed new branch wip/27162/hadrian-linkhs-response-file at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/27162/hadrian-linkhs-response…
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
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:
c95ea400 by fendor at 2026-04-10T12:43:12+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)
@@ -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/c95ea400caea1e4886eb35592d4260c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c95ea400caea1e4886eb35592d4260c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0