[Git][ghc/ghc][wip/fendor/homeunit-is-just] `HomeUnitEnv` should always have a concrete `HomeUnit`
by Hannes Siebenhandl (＠fendor) 06 Aug '26
by Hannes Siebenhandl (＠fendor) 06 Aug '26
06 Aug '26
Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC
Commits:
7718b39f by fendor at 2026-08-06T17:39:53+02:00
`HomeUnitEnv` should always have a concrete `HomeUnit`
The `HomeUnit` describes what kind of home unit a particular
`HomeUnitEnv` is.
Before we have initialised the `UnitState` via `initUnits`, we can't
actually tell well the `HomeUnit` is a definite one, or an indefinite
one, for example a backpack signature file.
That's why previously we maintained a `Maybe HomeUnit`.
However, a `HomeUnitEnv` always has at least a `UnitId` (accessible via
`DynFlags`).
Thus, we can fake a `HomeUnit` until we have actually initialised the
home unit and assume it is not a backpack unit.
- - - - -
21 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main/Hsc.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Errors.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Home.hs
- compiler/GHC/Unit/Home/Graph.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -678,7 +678,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do
hue
{ homeUnitEnv_units = unit_state
, homeUnitEnv_dflags = updated_dflags
- , homeUnitEnv_home_unit = Just home_unit
+ , homeUnitEnv_home_unit = home_unit
}
let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)
@@ -767,7 +767,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
{ homeUnitEnv_units = unit_state
, homeUnitEnv_dflags = updated_dflags
, homeUnitEnv_hpt = old_hpt
- , homeUnitEnv_home_unit = Just home_unit
+ , homeUnitEnv_home_unit = home_unit
}
let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph
@@ -891,7 +891,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do
{ homeUnitEnv_units = unit_state
, homeUnitEnv_dflags = updated_dflags
, homeUnitEnv_hpt = old_hpt
- , homeUnitEnv_home_unit = Just home_unit
+ , homeUnitEnv_home_unit = home_unit
}
-- When changing the DynFlags, we want the changes to apply to future
@@ -1684,7 +1684,7 @@ findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
let logger = hsc_logger hsc_env
liftIO $ trace_if logger (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual)
- let mhome_unit = hsc_home_unit_maybe hsc_env
+ let home_unit = hsc_home_unit hsc_env
let dflags = hsc_dflags hsc_env
let sec = initSourceErrorContext dflags
case pkgqual of
@@ -1695,7 +1695,7 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
Nothing -> liftIO $ do
res <- findImportedModule hsc_env mod_name pkgqual
case res of
- Found loc m | notHomeModuleMaybe mhome_unit m -> return m
+ Found loc m | notHomeModule home_unit m -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -473,7 +473,7 @@ addUnit u = do
, ue_home_unit_graph =
HUG.unitEnv_singleton
(homeUnitId home_unit)
- (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) (Just home_unit))
+ (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) home_unit)
, ue_eps = ue_eps old_unit_env
, ue_module_graph = ue_module_graph old_unit_env
, ue_uic = ue_uic old_unit_env
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,7 +7,6 @@ module GHC.Driver.Env
, hscUpdateFlags
, hscSetFlags
, hsc_home_unit
- , hsc_home_unit_maybe
, hsc_units
, hsc_HPT
, hsc_HUE
@@ -120,10 +119,7 @@ runInteractiveHsc :: HscEnv -> Hsc a -> IO a
runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)
hsc_home_unit :: HscEnv -> HomeUnit
-hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env
-
-hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit
-hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
+hsc_home_unit = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_homeUnitState . hsc_unit_env
@@ -388,7 +384,7 @@ lookupIfaceByModuleHsc hsc_env mod = do
lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod
mainModIs :: HomeUnitEnv -> Module
-mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))
+mainModIs hue = mkHomeModule (homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))
-- | Retrieve the target code interpreter
--
=====================================
compiler/GHC/Driver/Main/Hsc.hs
=====================================
@@ -112,7 +112,7 @@ newHscEnv top_dir dflags = do
where
home_unit_graph hpt = HUG.unitEnv_singleton
(homeUnitId_ dflags)
- (HUG.mkHomeUnitEnv emptyUnitState dflags hpt Nothing)
+ (HUG.mkHomeUnitEnv emptyUnitState dflags hpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing))
newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1665,7 +1665,7 @@ maybeRehydrateBefore hsc_env mni (Just mns) = do
where
initialise_knot_var hsc_env = liftIO $
- let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni)
+ let mod_name = homeModuleInstantiation (hsc_home_unit hsc_env) (moduleNodeInfoModule mni)
in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv
rehydrateAfter :: HscEnv
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -373,7 +373,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
let unit_env = hsc_unit_env hsc_env
- let home_unit = hsc_home_unit_maybe hsc_env
+ let home_unit = hsc_home_unit hsc_env
let tmpfs = hsc_tmpfs hsc_env
let tmpdir = tmpDir dflags
let platform = ue_platform unit_env
@@ -473,12 +473,11 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
-- These symbols are imported into the stub.c file via RtsAPI.h, and the
-- way we do the import depends on whether we're currently compiling
-- the base package or not.
- ++ (case home_unit of
- Just hu
- | isHomeUnitId hu ghcInternalUnitId
- , platformOS platform == OSMinGW32
- -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"]
- _ -> [])
+ ++ (if
+ | isHomeUnitId home_unit ghcInternalUnitId
+ , platformOS platform == OSMinGW32
+ -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"]
+ | otherwise -> [])
-- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -17,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 )
@@ -139,7 +140,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
{ homeUnitEnv_units = unit_state
, homeUnitEnv_dflags = updated_dflags
, homeUnitEnv_hpt = emptyHpt
- , homeUnitEnv_home_unit = Just home_unit
+ , homeUnitEnv_home_unit = home_unit
}
checkUnitCycles initial_dflags home_unit_graph
@@ -237,9 +238,7 @@ createUnitEnvFromFlags unitDflags = do
unitEnvList <- forM unitDflags $ \dflags -> do
emptyHpt <- emptyHomePackageTable
let newInternalUnitEnv =
- HUG.mkHomeUnitEnv emptyUnitState dflags emptyHpt Nothing
+ HUG.mkHomeUnitEnv emptyUnitState 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/HsToCore/Usage.hs
=====================================
@@ -82,7 +82,7 @@ mkUsageInfo uc plugins fc unit_env
= do
file_hashes <- liftIO $ mapM getFileHash dependent_files
dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs
- let hu = ue_unsafeHomeUnit unit_env
+ let hu = ue_homeUnit unit_env
-- Dependencies on object files due to TH and plugins
object_usages <- liftIO $ mkObjectUsage plugins fc needed_links needed_pkgs
let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env)
=====================================
compiler/GHC/Iface/Errors.hs
=====================================
@@ -27,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,12 +35,12 @@ cannotFindInterface us mhu p mn ifr =
cantFindInstalledErr
:: UnitState
- -> Maybe HomeUnit
+ -> HomeUnit
-> Profile
-> ModuleName
-> InstalledFindResult
-> CantFindInstalled
-cantFindInstalledErr unit_state mhome_unit profile mod_name find_result
+cantFindInstalledErr unit_state home_unit profile mod_name find_result
= CantFindInstalled mod_name more_info
where
build_tag = waysBuildTag (profileWays profile)
@@ -52,7 +52,7 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result
InstalledNotFound files mb_pkg
| Just pkg <- mb_pkg
- , notHomeUnitId mhome_unit pkg
+ , not (isHomeUnitId home_unit pkg)
-> not_found_in_package pkg $ fmap unsafeDecodeUtf files
| null files
@@ -102,7 +102,7 @@ cantFindErr _ _ mod_name (FoundMultiple mods)
cantFindErr unit_env profile mod_name find_result
= CantFindInstalled mod_name more_info
where
- mhome_unit = ue_homeUnit unit_env
+ home_unit = ue_homeUnit unit_env
more_info
= case find_result of
NoPackage pkg
@@ -111,12 +111,7 @@ cantFindErr unit_env profile mod_name find_result
, fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
, fr_unusables = unusables, fr_suggestions = suggest }
| Just pkg <- mb_pkg
- , Nothing <- mhome_unit -- no home-unit
- -> not_found_in_package (toUnitId pkg) files
-
- | Just pkg <- mb_pkg
- , Just home_unit <- mhome_unit -- there is a home-unit but the
- , not (isHomeUnit home_unit pkg) -- module isn't from it
+ , not (isHomeUnit home_unit pkg) -- module isn't from this home unit
-> not_found_in_package (toUnitId pkg) files
| not (null suggest)
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -446,14 +446,14 @@ loadInterface doc_str mod from
-- Check whether we have the interface already
; hsc_env <- getTopEnv
- ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)
+ ; let home_unit = ue_homeUnit (hsc_unit_env hsc_env)
; liftIO (lookupIfaceByModule hug (eps_PIT eps) mod) >>= \case {
Just iface
-> return (Succeeded iface) ; -- Already loaded
_ -> do {
-- READ THE MODULE IN
- ; read_result <- case wantHiBootFile mhome_unit eps mod from of
+ ; read_result <- case wantHiBootFile home_unit eps mod from of
Failed err -> return (Failed err)
Succeeded hi_boot_file -> do
hsc_env <- getTopEnv
@@ -549,7 +549,7 @@ loadInterface doc_str mod from
; warnPprTrace bad_boot "loadInterface" (ppr mod) $
updateEps_ $ \ eps ->
- if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
+ if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface
then eps
else if bad_boot
-- See Note [Loading your own hi-boot file]
@@ -714,12 +714,12 @@ dontLeakTheHUG thing_inside = do
-- | Returns @True@ if a 'ModIface' comes from an external package.
-- In this case, we should NOT load it into the EPS; the entities
-- should instead come from the local merged signature interface.
-is_external_sig :: Maybe HomeUnit -> ModIface -> Bool
-is_external_sig mhome_unit iface =
+is_external_sig :: HomeUnit -> ModIface -> Bool
+is_external_sig home_unit iface =
-- It's a signature iface...
mi_semantic_module iface /= mi_module iface &&
-- and it's not from the local package
- notHomeModuleMaybe mhome_unit (mi_module iface)
+ notHomeModule home_unit (mi_module iface)
-- | This is an improved version of 'findAndReadIface' which can also
-- handle the case when a user requests @p[A=<B>]:M@ but we only
@@ -743,13 +743,12 @@ computeInterface
-> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
computeInterface hsc_env doc_str hi_boot_file mod0 = do
massert (not (isHoleModule mod0))
- let mhome_unit = hsc_home_unit_maybe hsc_env
+ let home_unit = hsc_home_unit hsc_env
let find_iface m = findAndReadIface hsc_env doc_str
m mod0 hi_boot_file
case getModuleInstantiation mod0 of
(imod, Just indef)
- | Just home_unit <- mhome_unit
- , isHomeUnitIndefinite home_unit ->
+ | isHomeUnitIndefinite home_unit ->
find_iface imod >>= \case
Succeeded (iface0, path) ->
rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case
@@ -806,13 +805,13 @@ moduleFreeHolesPrecise doc_str mod
return (Succeeded (renameFreeHoles ifhs insts))
Failed err -> return (Failed err)
-wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom
+wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom
-> MaybeErr MissingInterfaceError IsBootInterface
-- Figure out whether we want Foo.hi or Foo.hi-boot
-wantHiBootFile mhome_unit eps mod from
+wantHiBootFile home_unit eps mod from
= case from of
ImportByUser usr_boot
- | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod
+ | usr_boot == IsBoot && notHomeModule home_unit mod
-> Failed (BadSourceImport mod)
| otherwise -> Succeeded usr_boot
@@ -820,7 +819,7 @@ wantHiBootFile mhome_unit eps mod from
-> Succeeded NotBoot
ImportBySystem
- | notHomeModuleMaybe mhome_unit mod
+ | notHomeModule home_unit mod
-> Succeeded NotBoot
-- If the module to be imported is not from this package
-- don't look it up in eps_is_boot, because that is keyed
@@ -894,7 +893,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
let profile = targetProfile dflags
unit_state = hsc_units hsc_env
name_cache = hsc_NC hsc_env
- mhome_unit = hsc_home_unit_maybe hsc_env
+ home_unit = hsc_home_unit hsc_env
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
@@ -933,7 +932,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
trace_if logger (text "...not found")
return $ Failed $ cannotFindInterface
unit_state
- mhome_unit
+ home_unit
profile
(moduleName mod)
err
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -160,22 +160,18 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
= HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case
Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info))
Nothing -> do
- -- It's not in the HPT because we are in one shot mode,
- -- so use the Finder to get a ModLocation...
- case ue_homeUnit unit_env of
- Nothing -> no_obj mod
- Just home_unit -> do
-
- let fc = ldFinderCache opts
- let fopts = ldFinderOpts opts
- mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
- case mb_stuff of
- Found loc _ -> do
- from_bc <- ldLoadByteCode opts mod loc
- maybe (fallback_no_bytecode home_unit mod) pure from_bc
- _ -> fallback_no_bytecode home_unit mod
+ -- It's not in the HPT because we are in one shot mode,
+ -- so use the Finder to get a ModLocation...
+ let fc = ldFinderCache opts
+ let fopts = ldFinderOpts opts
+ mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
+ case mb_stuff of
+ Found loc _ -> do
+ from_bc <- ldLoadByteCode opts mod loc
+ maybe (fallback_no_bytecode home_unit mod) pure from_bc
+ _ -> fallback_no_bytecode home_unit mod
where
-
+ home_unit = ue_homeUnit unit_env
fallback_no_bytecode home_unit mod = 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
=====================================
@@ -485,17 +485,15 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
let load_info mod = do
-- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps.
linkable <- HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case
- Nothing ->
+ Nothing -> do
-- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
- case ue_homeUnit unit_env of
- Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod)
- Just home_unit -> do
- mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod)
- case mb_stuff of
- Found loc mod -> found loc mod
- _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
+ mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod)
+ case mb_stuff of
+ Found loc mod -> found loc mod
+ _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
where
+ home_unit = ue_homeUnit unit_env
found loc mod = do {
mb_lnk <- findObjectLinkableMaybe mod loc ;
case mb_lnk of {
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -285,11 +285,11 @@ 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 home_unit mod ->
return (uniqDSetToList (moduleFreeHoles mod))
_ -> return []
where
- mhome_unit = hsc_home_unit_maybe hsc_env
+ home_unit = hsc_home_unit hsc_env
-- | Like @implicitRequirements'@, but returns either the module name, if it is
-- a free hole, or the instantiated unit the imported module is from, so that
@@ -301,13 +301,13 @@ implicitRequirementsShallow
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports
where
- mhome_unit = hsc_home_unit_maybe hsc_env
+ home_unit = hsc_home_unit hsc_env
go acc [] = pure acc
go (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 home_unit mod ->
case moduleUnit mod of
HoleUnit -> (moduleName mod : accL, accR)
RealUnit _ -> (accL, accR)
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -173,8 +173,8 @@ lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage)
lookupGlobal_maybe hsc_env name
= do { -- Try local envt
let mod = icInteractiveModule (hsc_IC hsc_env)
- mhome_unit = hsc_home_unit_maybe hsc_env
- tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
+ home_unit = hsc_home_unit hsc_env
+ tcg_semantic_mod = homeModuleInstantiation home_unit mod
; if nameIsLocalOrFrom tcg_semantic_mod name
then return $ Failed $ Left name
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -370,7 +370,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc =
; let
-- bangs to avoid leaking the env (#19356)
!dflags = hsc_dflags hsc_env
- !mhome_unit = hsc_home_unit_maybe hsc_env
+ !home_unit = hsc_home_unit hsc_env
!logger = hsc_logger hsc_env
maybe_rn_syntax :: forall a. a -> Maybe a ;
@@ -398,7 +398,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc =
, tcg_th_docs = th_docs_var
, tcg_mod = mod
- , tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
+ , tcg_semantic_mod = homeModuleInstantiation home_unit mod
, tcg_src = hsc_src
, tcg_rdr_env = emptyGlobalRdrEnv
, tcg_fix_env = emptyNameEnv
@@ -2578,11 +2578,11 @@ initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
; hsc_env <- getTopEnv
-- bangs to avoid leaking the envs (#19356)
- ; let !mhome_unit = hsc_home_unit_maybe hsc_env
+ ; let !home_unit = hsc_home_unit hsc_env
!knot_vars = tcg_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 home_unit
; let { if_env = IfGblEnv {
if_doc = text "initIfaceTcRn",
if_rec_types =
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -53,7 +53,6 @@ module GHC.Unit.Env
, ue_unitHomeUnit_maybe
, ue_updateHomeUnitEnv
, ue_all_home_unit_ids
- , ue_unsafeHomeUnit
-- * HUG Re-export
, HomeUnitGraph
@@ -235,14 +234,13 @@ preloadUnitsInfo' unit_env ids0 = all_infos
where
unit_state = HUG.homeUnitEnv_units (ue_currentHomeUnitEnv unit_env)
ids = ids0 ++ inst_ids
- inst_ids = case ue_homeUnit unit_env of
- Nothing -> []
- Just home_unit
- -- An indefinite package will have insts to HOLE,
- -- which is not a real package. Don't look it up.
- -- Fixes #14525
- | isHomeUnitIndefinite home_unit -> []
- | otherwise -> map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)
+ home_unit = ue_homeUnit unit_env
+ inst_ids
+ -- An indefinite package will have insts to HOLE,
+ -- which is not a real package. Don't look it up.
+ -- Fixes #14525
+ | isHomeUnitIndefinite home_unit = []
+ | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)
pkg_map = unitInfoMap unit_state
preload = preloadUnits unit_state
@@ -320,20 +318,15 @@ ue_setFlags dflags env =
-- Query and modify home units in HomeUnitEnv
-- -------------------------------------------------------
-ue_homeUnit :: UnitEnv -> Maybe HomeUnit
+ue_homeUnit :: UnitEnv -> HomeUnit
ue_homeUnit = HUG.homeUnitEnv_home_unit . ue_currentHomeUnitEnv
-ue_unsafeHomeUnit :: UnitEnv -> HomeUnit
-ue_unsafeHomeUnit ue = case ue_homeUnit ue of
- Nothing -> panic "ue_unsafeHomeUnit: No home unit"
- Just h -> h
-
ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid
ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit
ue_unitHomeUnit_maybe uid ue_env =
- HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env)
+ HUG.homeUnitEnv_home_unit <$> HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env)
-- -------------------------------------------------------
-- Query and modify the currently active unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -5,6 +5,7 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiWayIf #-}
-- | Module finder
module GHC.Unit.Finder (
@@ -184,7 +185,7 @@ getDirHash dir = do
findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule hsc_env mod pkg_qual =
let fc = hsc_FC hsc_env
- mb_home_unit = hsc_home_unit_maybe hsc_env
+ mb_home_unit = hsc_home_unit hsc_env
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
@@ -203,32 +204,29 @@ findImportedModuleNoHsc
-> FinderOpts
-> UnitEnv
-> HomeModuleNameProvidersMap
- -> Maybe HomeUnit
+ -> HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue home_module_name_providers_map home_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
- ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import
+ ThisPkg uid | homeUnitId home_unit == uid -> home_import
| Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
- | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts))
+ | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr home_unit_id $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
- mb_home_unit_id :: Maybe UnitId
- mb_home_unit_id = homeUnitId <$> mb_home_unit
+ home_unit_id :: UnitId
+ home_unit_id = homeUnitId home_unit
all_opts :: [(UnitId, FinderOpts)]
- all_opts = case mb_home_unit_id of
- Nothing -> other_fopts
- Just home_unit_id -> (home_unit_id, fopts) : other_fopts
+ all_opts =
+ (home_unit_id, fopts) : other_fopts
home_import :: IO FindResult
- home_import = case mb_home_unit of
- Just home_unit -> findHomeModule fc fopts home_unit mod_name
- Nothing -> pure $
- NoPackage (panic "findImportedModule: no home-unit")
+ home_import =
+ findHomeModule fc fopts home_unit mod_name
home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult
home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map mod_name
@@ -238,13 +236,11 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit
unqual_import :: IO FindResult
unqual_import = findHomeOrRegularPackageModule fc fopts ue
- home_module_name_providers_map mb_home_unit mod_name
+ home_module_name_providers_map home_unit mod_name
unit_state :: UnitState
- unit_state = case mb_home_unit_id of
- Nothing -> ue_homeUnitState ue
- Just home_unit_id -> HUG.homeUnitEnv_units $
- ue_findHomeUnitEnv home_unit_id ue
+ unit_state = HUG.homeUnitEnv_units $
+ ue_findHomeUnitEnv home_unit_id ue
other_fopts :: [(UnitId, FinderOpts)]
other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map
@@ -259,24 +255,22 @@ findPluginModuleNoHsc
-> FinderOpts
-> UnitEnv
-> HomeModuleNameProvidersMap
- -> Maybe HomeUnit
+ -> HomeUnit
-> ModuleName
-> IO FindResult
-findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name =
+findPluginModuleNoHsc fc fopts ue home_module_name_providers_map home_unit mod_name =
findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
- mb_home_unit mod_name
+ home_unit mod_name
`orIfNotFound`
findExposedPluginPackageModule fc fopts unit_state mod_name
where
unit_state = HUG.homeUnitEnv_units $
ue_findHomeUnitEnv (homeUnitId home_unit) ue
-findPluginModuleNoHsc fc fopts ue _ Nothing mod_name =
- findExposedPluginPackageModule fc fopts (ue_homeUnitState ue) mod_name
findPluginModule :: HscEnv -> ModuleName -> IO FindResult
findPluginModule hsc_env mod_name = do
let fc = hsc_FC hsc_env
- mb_home_unit = hsc_home_unit_maybe hsc_env
+ mb_home_unit = hsc_home_unit hsc_env
home_module_name_providers_map =
mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env)
findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env))
@@ -351,7 +345,7 @@ findHomeUnitDepModule fc ue home_module_name_providers_map mod_name (uid, opts)
| Just real_mod_name
<- lookupUniqMap (finder_reexportedModules opts) mod_name
= findHomeOrRegularPackageModule fc opts ue home_module_name_providers_map
- (Just $ DefiniteHomeUnit uid Nothing)
+ (DefiniteHomeUnit uid Nothing)
real_mod_name
| elementOfUniqSet mod_name (finder_hiddenModules opts)
= return (mkHomeHidden uid)
@@ -367,26 +361,21 @@ findHomeModuleAmongDeps
-> FinderOpts
-> UnitEnv
-> HomeModuleNameProvidersMap
- -> Maybe HomeUnit
+ -> HomeUnit
-> ModuleName
-> IO FindResult
-findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit mod_name =
+findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map home_unit mod_name =
foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts)
-- Do not try to be smart and change this to `foldr orIfNotFound home_import
-- (map home_pkg_import other_fopts)`, as that would not be the same.
-- `home_import` is first because we need to first look within the current
-- unit before looking at the other units in order.
where
- home_import = case mb_home_unit of
- Just home_unit -> findHomeModule fc fopts home_unit mod_name
- Nothing -> pure $
- NoPackage (panic "findHomeModuleAmongDeps: no home-unit")
+ home_import = findHomeModule fc fopts home_unit mod_name
+
home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map mod_name
- unit_state = case homeUnitId <$> mb_home_unit of
- Nothing -> ue_homeUnitState ue
- Just home_unit_id -> HUG.homeUnitEnv_units $
- ue_findHomeUnitEnv home_unit_id ue
+ unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map
unit_state mod_name
@@ -397,32 +386,29 @@ findHomeOrRegularPackageModule
-> FinderOpts
-> UnitEnv
-> HomeModuleNameProvidersMap
- -> Maybe HomeUnit
+ -> HomeUnit
-> ModuleName
-> IO FindResult
-findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit mod_name =
+findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map home_unit mod_name =
findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
- mb_home_unit mod_name
+ home_unit mod_name
`orIfNotFound`
findExposedPackageModule fc fopts unit_state mod_name NoPkgQual
where
- unit_state = case homeUnitId <$> mb_home_unit of
- Nothing -> ue_homeUnitState ue
- Just home_unit_id -> HUG.homeUnitEnv_units $
- ue_findHomeUnitEnv home_unit_id ue
+ unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
-- | A version of findExactModule which takes the exact parts of the HscEnv it needs
-- directly.
-findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
-findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do
- res <- case mb_home_unit of
- Just home_unit
+findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
+findExactModuleNoHsc fc fopts other_fopts unit_state home_unit mod is_boot = do
+ res <-
+ if
| isHomeInstalledModule home_unit mod
-> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)
| Just home_fopts <- HUG.unitEnv_lookup_maybe (moduleUnit mod) other_fopts
-> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)
- _ -> findPackageModule fc unit_state fopts mod
+ | otherwise -> findPackageModule fc unit_state fopts mod
case (res, is_boot) of
(InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc))
_ -> return res
@@ -438,7 +424,7 @@ findExactModule hsc_env mod is_boot = do
let dflags = hsc_dflags hsc_env
let fc = hsc_FC hsc_env
let unit_state = hsc_units hsc_env
- let home_unit = hsc_home_unit_maybe hsc_env
+ let home_unit = hsc_home_unit hsc_env
let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)
findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot
=====================================
compiler/GHC/Unit/Home.hs
=====================================
@@ -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
=====================================
@@ -150,11 +150,11 @@ data HomeUnitEnv = HomeUnitEnv
--
-- (This changes a previous invariant: changed Jan 05.)
- , homeUnitEnv_home_unit :: !(Maybe HomeUnit)
+ , homeUnitEnv_home_unit :: !HomeUnit
-- ^ Home-unit
}
-mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
+mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> HomeUnit -> HomeUnitEnv
mkHomeUnitEnv us dflags hpt home_unit = HomeUnitEnv
{ homeUnitEnv_units = us
, homeUnitEnv_dflags = dflags
@@ -372,6 +372,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
=====================================
@@ -859,7 +859,7 @@ installInteractiveHomeUnits dflags = do
(unit_state,home_unit,_mconstants) <-
liftIO $ initUnits logger dflags unit_index all_home_units
hpt <- liftIO emptyHomePackageTable
- pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit))
+ pure (HUG.mkHomeUnitEnv unit_state dflags hpt home_unit)
concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag]
concatPackageDbStacksUsingLongestCommonPrefix stacks =
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7718b39f1883b4a66176889b37379fd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7718b39f1883b4a66176889b37379fd…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/fendor/homeunit-is-just] A HomeUnitEnv should always have a concrete HomeUnit
by Hannes Siebenhandl (＠fendor) 06 Aug '26
by Hannes Siebenhandl (＠fendor) 06 Aug '26
06 Aug '26
Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC
Commits:
d5eb7a82 by fendor at 2026-08-06T17:06:21+02:00
A HomeUnitEnv should always have a concrete HomeUnit
The `HomeUnit` describes what kind of home unit a particular
`HomeUnitEnv` is.
Before we have initialised the `UnitState` via `initUnits`, we can't
actually tell well the `HomeUnit` is a definite one, or an indefinite
one, for example a backpack signature file.
That's why previously we maintained a `Maybe HomeUnit`.
However, a `HomeUnitEnv` always has at least a `UnitId` (accessible via
`DynFlags`).
Thus, we can fake a `HomeUnit` until we have actually initialised the
home unit and assume it is not a backpack unit.
- - - - -
21 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main/Hsc.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Errors.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Home.hs
- compiler/GHC/Unit/Home/Graph.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -678,7 +678,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do
hue
{ homeUnitEnv_units = unit_state
, homeUnitEnv_dflags = updated_dflags
- , homeUnitEnv_home_unit = Just home_unit
+ , homeUnitEnv_home_unit = home_unit
}
let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)
@@ -767,7 +767,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
{ homeUnitEnv_units = unit_state
, homeUnitEnv_dflags = updated_dflags
, homeUnitEnv_hpt = old_hpt
- , homeUnitEnv_home_unit = Just home_unit
+ , homeUnitEnv_home_unit = home_unit
}
let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph
@@ -891,7 +891,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do
{ homeUnitEnv_units = unit_state
, homeUnitEnv_dflags = updated_dflags
, homeUnitEnv_hpt = old_hpt
- , homeUnitEnv_home_unit = Just home_unit
+ , homeUnitEnv_home_unit = home_unit
}
-- When changing the DynFlags, we want the changes to apply to future
@@ -1684,7 +1684,7 @@ findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
let logger = hsc_logger hsc_env
liftIO $ trace_if logger (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual)
- let mhome_unit = hsc_home_unit_maybe hsc_env
+ let home_unit = hsc_home_unit hsc_env
let dflags = hsc_dflags hsc_env
let sec = initSourceErrorContext dflags
case pkgqual of
@@ -1695,7 +1695,7 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
Nothing -> liftIO $ do
res <- findImportedModule hsc_env mod_name pkgqual
case res of
- Found loc m | notHomeModuleMaybe mhome_unit m -> return m
+ Found loc m | notHomeModule home_unit m -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -473,7 +473,7 @@ addUnit u = do
, ue_home_unit_graph =
HUG.unitEnv_singleton
(homeUnitId home_unit)
- (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) (Just home_unit))
+ (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) home_unit)
, ue_eps = ue_eps old_unit_env
, ue_module_graph = ue_module_graph old_unit_env
, ue_uic = ue_uic old_unit_env
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,7 +7,6 @@ module GHC.Driver.Env
, hscUpdateFlags
, hscSetFlags
, hsc_home_unit
- , hsc_home_unit_maybe
, hsc_units
, hsc_HPT
, hsc_HUE
@@ -120,10 +119,7 @@ runInteractiveHsc :: HscEnv -> Hsc a -> IO a
runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)
hsc_home_unit :: HscEnv -> HomeUnit
-hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env
-
-hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit
-hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
+hsc_home_unit = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_homeUnitState . hsc_unit_env
@@ -388,7 +384,7 @@ lookupIfaceByModuleHsc hsc_env mod = do
lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod
mainModIs :: HomeUnitEnv -> Module
-mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))
+mainModIs hue = mkHomeModule (homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))
-- | Retrieve the target code interpreter
--
=====================================
compiler/GHC/Driver/Main/Hsc.hs
=====================================
@@ -112,7 +112,7 @@ newHscEnv top_dir dflags = do
where
home_unit_graph hpt = HUG.unitEnv_singleton
(homeUnitId_ dflags)
- (HUG.mkHomeUnitEnv emptyUnitState dflags hpt Nothing)
+ (HUG.mkHomeUnitEnv emptyUnitState dflags hpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing))
newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1665,7 +1665,7 @@ maybeRehydrateBefore hsc_env mni (Just mns) = do
where
initialise_knot_var hsc_env = liftIO $
- let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni)
+ let mod_name = homeModuleInstantiation (hsc_home_unit hsc_env) (moduleNodeInfoModule mni)
in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv
rehydrateAfter :: HscEnv
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -373,7 +373,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
let unit_env = hsc_unit_env hsc_env
- let home_unit = hsc_home_unit_maybe hsc_env
+ let home_unit = hsc_home_unit hsc_env
let tmpfs = hsc_tmpfs hsc_env
let tmpdir = tmpDir dflags
let platform = ue_platform unit_env
@@ -474,7 +474,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 )
@@ -139,7 +140,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
{ homeUnitEnv_units = unit_state
, homeUnitEnv_dflags = updated_dflags
, homeUnitEnv_hpt = emptyHpt
- , homeUnitEnv_home_unit = Just home_unit
+ , homeUnitEnv_home_unit = home_unit
}
checkUnitCycles initial_dflags home_unit_graph
@@ -237,9 +238,7 @@ createUnitEnvFromFlags unitDflags = do
unitEnvList <- forM unitDflags $ \dflags -> do
emptyHpt <- emptyHomePackageTable
let newInternalUnitEnv =
- HUG.mkHomeUnitEnv emptyUnitState dflags emptyHpt Nothing
+ HUG.mkHomeUnitEnv emptyUnitState 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/HsToCore/Usage.hs
=====================================
@@ -82,7 +82,7 @@ mkUsageInfo uc plugins fc unit_env
= do
file_hashes <- liftIO $ mapM getFileHash dependent_files
dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs
- let hu = ue_unsafeHomeUnit unit_env
+ let hu = ue_homeUnit unit_env
-- Dependencies on object files due to TH and plugins
object_usages <- liftIO $ mkObjectUsage plugins fc needed_links needed_pkgs
let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env)
=====================================
compiler/GHC/Iface/Errors.hs
=====================================
@@ -27,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,12 +35,12 @@ cannotFindInterface us mhu p mn ifr =
cantFindInstalledErr
:: UnitState
- -> Maybe HomeUnit
+ -> HomeUnit
-> Profile
-> ModuleName
-> InstalledFindResult
-> CantFindInstalled
-cantFindInstalledErr unit_state mhome_unit profile mod_name find_result
+cantFindInstalledErr unit_state home_unit profile mod_name find_result
= CantFindInstalled mod_name more_info
where
build_tag = waysBuildTag (profileWays profile)
@@ -52,7 +52,7 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result
InstalledNotFound files mb_pkg
| Just pkg <- mb_pkg
- , notHomeUnitId mhome_unit pkg
+ , not (isHomeUnitId home_unit pkg)
-> not_found_in_package pkg $ fmap unsafeDecodeUtf files
| null files
@@ -102,7 +102,7 @@ cantFindErr _ _ mod_name (FoundMultiple mods)
cantFindErr unit_env profile mod_name find_result
= CantFindInstalled mod_name more_info
where
- mhome_unit = ue_homeUnit unit_env
+ home_unit = ue_homeUnit unit_env
more_info
= case find_result of
NoPackage pkg
@@ -111,12 +111,7 @@ cantFindErr unit_env profile mod_name find_result
, fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
, fr_unusables = unusables, fr_suggestions = suggest }
| Just pkg <- mb_pkg
- , Nothing <- mhome_unit -- no home-unit
- -> not_found_in_package (toUnitId pkg) files
-
- | Just pkg <- mb_pkg
- , Just home_unit <- mhome_unit -- there is a home-unit but the
- , not (isHomeUnit home_unit pkg) -- module isn't from it
+ , not (isHomeUnit home_unit pkg) -- module isn't from this home unit
-> not_found_in_package (toUnitId pkg) files
| not (null suggest)
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -446,14 +446,14 @@ loadInterface doc_str mod from
-- Check whether we have the interface already
; hsc_env <- getTopEnv
- ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)
+ ; let home_unit = ue_homeUnit (hsc_unit_env hsc_env)
; liftIO (lookupIfaceByModule hug (eps_PIT eps) mod) >>= \case {
Just iface
-> return (Succeeded iface) ; -- Already loaded
_ -> do {
-- READ THE MODULE IN
- ; read_result <- case wantHiBootFile mhome_unit eps mod from of
+ ; read_result <- case wantHiBootFile home_unit eps mod from of
Failed err -> return (Failed err)
Succeeded hi_boot_file -> do
hsc_env <- getTopEnv
@@ -549,7 +549,7 @@ loadInterface doc_str mod from
; warnPprTrace bad_boot "loadInterface" (ppr mod) $
updateEps_ $ \ eps ->
- if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
+ if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface
then eps
else if bad_boot
-- See Note [Loading your own hi-boot file]
@@ -714,12 +714,12 @@ dontLeakTheHUG thing_inside = do
-- | Returns @True@ if a 'ModIface' comes from an external package.
-- In this case, we should NOT load it into the EPS; the entities
-- should instead come from the local merged signature interface.
-is_external_sig :: Maybe HomeUnit -> ModIface -> Bool
-is_external_sig mhome_unit iface =
+is_external_sig :: HomeUnit -> ModIface -> Bool
+is_external_sig home_unit iface =
-- It's a signature iface...
mi_semantic_module iface /= mi_module iface &&
-- and it's not from the local package
- notHomeModuleMaybe mhome_unit (mi_module iface)
+ notHomeModule home_unit (mi_module iface)
-- | This is an improved version of 'findAndReadIface' which can also
-- handle the case when a user requests @p[A=<B>]:M@ but we only
@@ -743,13 +743,12 @@ computeInterface
-> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
computeInterface hsc_env doc_str hi_boot_file mod0 = do
massert (not (isHoleModule mod0))
- let mhome_unit = hsc_home_unit_maybe hsc_env
+ let home_unit = hsc_home_unit hsc_env
let find_iface m = findAndReadIface hsc_env doc_str
m mod0 hi_boot_file
case getModuleInstantiation mod0 of
(imod, Just indef)
- | Just home_unit <- mhome_unit
- , isHomeUnitIndefinite home_unit ->
+ | isHomeUnitIndefinite home_unit ->
find_iface imod >>= \case
Succeeded (iface0, path) ->
rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case
@@ -806,13 +805,13 @@ moduleFreeHolesPrecise doc_str mod
return (Succeeded (renameFreeHoles ifhs insts))
Failed err -> return (Failed err)
-wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom
+wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom
-> MaybeErr MissingInterfaceError IsBootInterface
-- Figure out whether we want Foo.hi or Foo.hi-boot
-wantHiBootFile mhome_unit eps mod from
+wantHiBootFile home_unit eps mod from
= case from of
ImportByUser usr_boot
- | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod
+ | usr_boot == IsBoot && notHomeModule home_unit mod
-> Failed (BadSourceImport mod)
| otherwise -> Succeeded usr_boot
@@ -820,7 +819,7 @@ wantHiBootFile mhome_unit eps mod from
-> Succeeded NotBoot
ImportBySystem
- | notHomeModuleMaybe mhome_unit mod
+ | notHomeModule home_unit mod
-> Succeeded NotBoot
-- If the module to be imported is not from this package
-- don't look it up in eps_is_boot, because that is keyed
@@ -894,7 +893,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
let profile = targetProfile dflags
unit_state = hsc_units hsc_env
name_cache = hsc_NC hsc_env
- mhome_unit = hsc_home_unit_maybe hsc_env
+ home_unit = hsc_home_unit hsc_env
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
@@ -933,7 +932,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
trace_if logger (text "...not found")
return $ Failed $ cannotFindInterface
unit_state
- mhome_unit
+ home_unit
profile
(moduleName mod)
err
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -160,22 +160,18 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
= HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case
Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info))
Nothing -> do
- -- It's not in the HPT because we are in one shot mode,
- -- so use the Finder to get a ModLocation...
- case ue_homeUnit unit_env of
- Nothing -> no_obj mod
- Just home_unit -> do
-
- let fc = ldFinderCache opts
- let fopts = ldFinderOpts opts
- mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
- case mb_stuff of
- Found loc _ -> do
- from_bc <- ldLoadByteCode opts mod loc
- maybe (fallback_no_bytecode home_unit mod) pure from_bc
- _ -> fallback_no_bytecode home_unit mod
+ -- It's not in the HPT because we are in one shot mode,
+ -- so use the Finder to get a ModLocation...
+ let fc = ldFinderCache opts
+ let fopts = ldFinderOpts opts
+ mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
+ case mb_stuff of
+ Found loc _ -> do
+ from_bc <- ldLoadByteCode opts mod loc
+ maybe (fallback_no_bytecode home_unit mod) pure from_bc
+ _ -> fallback_no_bytecode home_unit mod
where
-
+ home_unit = ue_homeUnit unit_env
fallback_no_bytecode home_unit mod = 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
=====================================
@@ -485,17 +485,15 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
let load_info mod = do
-- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps.
linkable <- HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case
- Nothing ->
+ Nothing -> do
-- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
- case ue_homeUnit unit_env of
- Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod)
- Just home_unit -> do
- mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod)
- case mb_stuff of
- Found loc mod -> found loc mod
- _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
+ mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod)
+ case mb_stuff of
+ Found loc mod -> found loc mod
+ _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
where
+ home_unit = ue_homeUnit unit_env
found loc mod = do {
mb_lnk <- findObjectLinkableMaybe mod loc ;
case mb_lnk of {
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -285,11 +285,11 @@ 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 home_unit mod ->
return (uniqDSetToList (moduleFreeHoles mod))
_ -> return []
where
- mhome_unit = hsc_home_unit_maybe hsc_env
+ home_unit = hsc_home_unit hsc_env
-- | Like @implicitRequirements'@, but returns either the module name, if it is
-- a free hole, or the instantiated unit the imported module is from, so that
@@ -301,13 +301,13 @@ implicitRequirementsShallow
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports
where
- mhome_unit = hsc_home_unit_maybe hsc_env
+ home_unit = hsc_home_unit hsc_env
go acc [] = pure acc
go (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 home_unit mod ->
case moduleUnit mod of
HoleUnit -> (moduleName mod : accL, accR)
RealUnit _ -> (accL, accR)
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -173,8 +173,8 @@ lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage)
lookupGlobal_maybe hsc_env name
= do { -- Try local envt
let mod = icInteractiveModule (hsc_IC hsc_env)
- mhome_unit = hsc_home_unit_maybe hsc_env
- tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
+ home_unit = hsc_home_unit hsc_env
+ tcg_semantic_mod = homeModuleInstantiation home_unit mod
; if nameIsLocalOrFrom tcg_semantic_mod name
then return $ Failed $ Left name
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -370,7 +370,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc =
; let
-- bangs to avoid leaking the env (#19356)
!dflags = hsc_dflags hsc_env
- !mhome_unit = hsc_home_unit_maybe hsc_env
+ !home_unit = hsc_home_unit hsc_env
!logger = hsc_logger hsc_env
maybe_rn_syntax :: forall a. a -> Maybe a ;
@@ -398,7 +398,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc =
, tcg_th_docs = th_docs_var
, tcg_mod = mod
- , tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
+ , tcg_semantic_mod = homeModuleInstantiation home_unit mod
, tcg_src = hsc_src
, tcg_rdr_env = emptyGlobalRdrEnv
, tcg_fix_env = emptyNameEnv
@@ -2578,11 +2578,11 @@ initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
; hsc_env <- getTopEnv
-- bangs to avoid leaking the envs (#19356)
- ; let !mhome_unit = hsc_home_unit_maybe hsc_env
+ ; let !home_unit = hsc_home_unit hsc_env
!knot_vars = tcg_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 home_unit
; let { if_env = IfGblEnv {
if_doc = text "initIfaceTcRn",
if_rec_types =
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -53,7 +53,6 @@ module GHC.Unit.Env
, ue_unitHomeUnit_maybe
, ue_updateHomeUnitEnv
, ue_all_home_unit_ids
- , ue_unsafeHomeUnit
-- * HUG Re-export
, HomeUnitGraph
@@ -235,14 +234,13 @@ preloadUnitsInfo' unit_env ids0 = all_infos
where
unit_state = HUG.homeUnitEnv_units (ue_currentHomeUnitEnv unit_env)
ids = ids0 ++ inst_ids
- inst_ids = case ue_homeUnit unit_env of
- Nothing -> []
- Just home_unit
- -- An indefinite package will have insts to HOLE,
- -- which is not a real package. Don't look it up.
- -- Fixes #14525
- | isHomeUnitIndefinite home_unit -> []
- | otherwise -> map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)
+ home_unit = ue_homeUnit unit_env
+ inst_ids
+ -- An indefinite package will have insts to HOLE,
+ -- which is not a real package. Don't look it up.
+ -- Fixes #14525
+ | isHomeUnitIndefinite home_unit = []
+ | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)
pkg_map = unitInfoMap unit_state
preload = preloadUnits unit_state
@@ -320,20 +318,15 @@ ue_setFlags dflags env =
-- Query and modify home units in HomeUnitEnv
-- -------------------------------------------------------
-ue_homeUnit :: UnitEnv -> Maybe HomeUnit
+ue_homeUnit :: UnitEnv -> HomeUnit
ue_homeUnit = HUG.homeUnitEnv_home_unit . ue_currentHomeUnitEnv
-ue_unsafeHomeUnit :: UnitEnv -> HomeUnit
-ue_unsafeHomeUnit ue = case ue_homeUnit ue of
- Nothing -> panic "ue_unsafeHomeUnit: No home unit"
- Just h -> h
-
ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid
ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit
ue_unitHomeUnit_maybe uid ue_env =
- HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env)
+ HUG.homeUnitEnv_home_unit <$> HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env)
-- -------------------------------------------------------
-- Query and modify the currently active unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -184,7 +184,7 @@ getDirHash dir = do
findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule hsc_env mod pkg_qual =
let fc = hsc_FC hsc_env
- mb_home_unit = hsc_home_unit_maybe hsc_env
+ mb_home_unit = hsc_home_unit hsc_env
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
@@ -203,32 +203,29 @@ findImportedModuleNoHsc
-> FinderOpts
-> UnitEnv
-> HomeModuleNameProvidersMap
- -> Maybe HomeUnit
+ -> HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue home_module_name_providers_map home_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
- ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import
+ ThisPkg uid | homeUnitId home_unit == uid -> home_import
| Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
- | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts))
+ | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr home_unit_id $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
- mb_home_unit_id :: Maybe UnitId
- mb_home_unit_id = homeUnitId <$> mb_home_unit
+ home_unit_id :: UnitId
+ home_unit_id = homeUnitId home_unit
all_opts :: [(UnitId, FinderOpts)]
- all_opts = case mb_home_unit_id of
- Nothing -> other_fopts
- Just home_unit_id -> (home_unit_id, fopts) : other_fopts
+ all_opts =
+ (home_unit_id, fopts) : other_fopts
home_import :: IO FindResult
- home_import = case mb_home_unit of
- Just home_unit -> findHomeModule fc fopts home_unit mod_name
- Nothing -> pure $
- NoPackage (panic "findImportedModule: no home-unit")
+ home_import =
+ findHomeModule fc fopts home_unit mod_name
home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult
home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map mod_name
@@ -238,13 +235,11 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit
unqual_import :: IO FindResult
unqual_import = findHomeOrRegularPackageModule fc fopts ue
- home_module_name_providers_map mb_home_unit mod_name
+ home_module_name_providers_map home_unit mod_name
unit_state :: UnitState
- unit_state = case mb_home_unit_id of
- Nothing -> ue_homeUnitState ue
- Just home_unit_id -> HUG.homeUnitEnv_units $
- ue_findHomeUnitEnv home_unit_id ue
+ unit_state = HUG.homeUnitEnv_units $
+ ue_findHomeUnitEnv home_unit_id ue
other_fopts :: [(UnitId, FinderOpts)]
other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map
@@ -259,24 +254,22 @@ findPluginModuleNoHsc
-> FinderOpts
-> UnitEnv
-> HomeModuleNameProvidersMap
- -> Maybe HomeUnit
+ -> HomeUnit
-> ModuleName
-> IO FindResult
-findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name =
+findPluginModuleNoHsc fc fopts ue home_module_name_providers_map home_unit mod_name =
findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
- mb_home_unit mod_name
+ home_unit mod_name
`orIfNotFound`
findExposedPluginPackageModule fc fopts unit_state mod_name
where
unit_state = HUG.homeUnitEnv_units $
ue_findHomeUnitEnv (homeUnitId home_unit) ue
-findPluginModuleNoHsc fc fopts ue _ Nothing mod_name =
- findExposedPluginPackageModule fc fopts (ue_homeUnitState ue) mod_name
findPluginModule :: HscEnv -> ModuleName -> IO FindResult
findPluginModule hsc_env mod_name = do
let fc = hsc_FC hsc_env
- mb_home_unit = hsc_home_unit_maybe hsc_env
+ mb_home_unit = hsc_home_unit hsc_env
home_module_name_providers_map =
mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env)
findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env))
@@ -351,7 +344,7 @@ findHomeUnitDepModule fc ue home_module_name_providers_map mod_name (uid, opts)
| Just real_mod_name
<- lookupUniqMap (finder_reexportedModules opts) mod_name
= findHomeOrRegularPackageModule fc opts ue home_module_name_providers_map
- (Just $ DefiniteHomeUnit uid Nothing)
+ (DefiniteHomeUnit uid Nothing)
real_mod_name
| elementOfUniqSet mod_name (finder_hiddenModules opts)
= return (mkHomeHidden uid)
@@ -367,26 +360,21 @@ findHomeModuleAmongDeps
-> FinderOpts
-> UnitEnv
-> HomeModuleNameProvidersMap
- -> Maybe HomeUnit
+ -> HomeUnit
-> ModuleName
-> IO FindResult
-findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit mod_name =
+findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map home_unit mod_name =
foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts)
-- Do not try to be smart and change this to `foldr orIfNotFound home_import
-- (map home_pkg_import other_fopts)`, as that would not be the same.
-- `home_import` is first because we need to first look within the current
-- unit before looking at the other units in order.
where
- home_import = case mb_home_unit of
- Just home_unit -> findHomeModule fc fopts home_unit mod_name
- Nothing -> pure $
- NoPackage (panic "findHomeModuleAmongDeps: no home-unit")
+ home_import = findHomeModule fc fopts home_unit mod_name
+
home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map mod_name
- unit_state = case homeUnitId <$> mb_home_unit of
- Nothing -> ue_homeUnitState ue
- Just home_unit_id -> HUG.homeUnitEnv_units $
- ue_findHomeUnitEnv home_unit_id ue
+ unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map
unit_state mod_name
@@ -397,32 +385,29 @@ findHomeOrRegularPackageModule
-> FinderOpts
-> UnitEnv
-> HomeModuleNameProvidersMap
- -> Maybe HomeUnit
+ -> HomeUnit
-> ModuleName
-> IO FindResult
-findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit mod_name =
+findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map home_unit mod_name =
findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
- mb_home_unit mod_name
+ home_unit mod_name
`orIfNotFound`
findExposedPackageModule fc fopts unit_state mod_name NoPkgQual
where
- unit_state = case homeUnitId <$> mb_home_unit of
- Nothing -> ue_homeUnitState ue
- Just home_unit_id -> HUG.homeUnitEnv_units $
- ue_findHomeUnitEnv home_unit_id ue
+ unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
-- | A version of findExactModule which takes the exact parts of the HscEnv it needs
-- directly.
-findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
-findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do
- res <- case mb_home_unit of
- Just home_unit
+findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
+findExactModuleNoHsc fc fopts other_fopts unit_state home_unit mod is_boot = do
+ res <- case home_unit of
+ _
| 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
@@ -438,7 +423,7 @@ findExactModule hsc_env mod is_boot = do
let dflags = hsc_dflags hsc_env
let fc = hsc_FC hsc_env
let unit_state = hsc_units hsc_env
- let home_unit = hsc_home_unit_maybe hsc_env
+ let home_unit = hsc_home_unit hsc_env
let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)
findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot
=====================================
compiler/GHC/Unit/Home.hs
=====================================
@@ -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
=====================================
@@ -150,11 +150,11 @@ data HomeUnitEnv = HomeUnitEnv
--
-- (This changes a previous invariant: changed Jan 05.)
- , homeUnitEnv_home_unit :: !(Maybe HomeUnit)
+ , homeUnitEnv_home_unit :: !HomeUnit
-- ^ Home-unit
}
-mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
+mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> HomeUnit -> HomeUnitEnv
mkHomeUnitEnv us dflags hpt home_unit = HomeUnitEnv
{ homeUnitEnv_units = us
, homeUnitEnv_dflags = dflags
@@ -372,6 +372,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
=====================================
@@ -859,7 +859,7 @@ installInteractiveHomeUnits dflags = do
(unit_state,home_unit,_mconstants) <-
liftIO $ initUnits logger dflags unit_index all_home_units
hpt <- liftIO emptyHomePackageTable
- pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit))
+ pure (HUG.mkHomeUnitEnv unit_state dflags hpt home_unit)
concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag]
concatPackageDbStacksUsingLongestCommonPrefix stacks =
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5eb7a82ed261166d175f421a2e8e4f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5eb7a82ed261166d175f421a2e8e4f…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/spj-reinstallable-base2] Allow GHC.Essentials to be hidden
by sheaf (＠sheaf) 06 Aug '26
by sheaf (＠sheaf) 06 Aug '26
06 Aug '26
sheaf pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC
Commits:
460a1b7d by sheaf at 2026-08-06T16:45:23+02:00
Allow GHC.Essentials to be hidden
This commit overhauls several aspects of the known entity handling,
in order to allow GHC.Essentials to be hidden without a proliferation
of special cases in the compiler.
The main contribution is to introduce the 'ImportEdge' datatype which
cleans up a lot of ad-hoc handling relating to 'ModSummary', fixing #27603.
This allows us to reduce duplication, e.g. by having Backpack reuse
'mkImportEdges' instead of replicating the "add implicit imports" logic.
It also makes it easier to avoid undesirable edge cases (such as making
sure that the Template Haskell 'reifyModule' function does not leak
the implicit GHC.Essentials import).
Other changes:
- Cache the result of looking up GHC.Essentials (in TcM and DsM
environments) to avoid redundant work.
This reduces allocations on LinkableUsage01 and hard_hole_fits.
- Properly look up known entities for StaticPointers like we do for
other known entities everywhere else. This allows e.g. modules in
ghc-internal to use -XStaticPointers.
- When using multiple home units, we are now careful to handle the
situation in which we may have multiple GHC.Essentials modules
around. See the new tests under 'driver/multipleHomeUnits'.
- - - - -
86 changed files:
- compiler/GHC.hs
- compiler/GHC/Builtin.hs
- compiler/GHC/Builtin/Modules.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Config/Tidy.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Errors/Ppr.hs
- compiler/GHC/Iface/Errors/Types.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Plugin.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/External.hs
- compiler/GHC/Unit/External/ModuleOrigin.hs
- compiler/GHC/Unit/External/Providers.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/Types.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- libraries/base/base.cabal.in
- testsuite/driver/testutil.py
- testsuite/tests/cabal/T12485/Makefile
- testsuite/tests/driver/T27013e/T27013e.hs
- testsuite/tests/driver/T27013e/T27013e.stderr
- testsuite/tests/driver/T27013f/T27013f.hs
- testsuite/tests/driver/T27013f/T27013f.stderr
- + testsuite/tests/driver/T27013g/T27013g.hs
- + testsuite/tests/driver/T27013g/all.T
- + testsuite/tests/driver/T27013h/GHC/Essentials.hs
- + testsuite/tests/driver/T27013h/T27013h.stderr
- + testsuite/tests/driver/T27013h/all.T
- + testsuite/tests/driver/T27013h/unitT27013h
- + testsuite/tests/driver/T27013i/T27013i.hs
- + testsuite/tests/driver/T27013i/T27013i.stderr
- + testsuite/tests/driver/T27013i/all.T
- testsuite/tests/driver/multipleHomeUnits/Makefile
- testsuite/tests/driver/multipleHomeUnits/all.T
- + testsuite/tests/driver/multipleHomeUnits/essentials-home/GHC/Essentials.hs
- + testsuite/tests/driver/multipleHomeUnits/essentials-order-base/B.hs
- + testsuite/tests/driver/multipleHomeUnits/essentials-order-user/U.hs
- + testsuite/tests/driver/multipleHomeUnits/essentials-user/M.hs
- testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stderr
- + testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_essentials.stdout
- + testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_essentials_order.stderr
- + testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_essentials_recomp.stdout
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsHome
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsHomeHidden
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsOrderBase
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsOrderUser
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsUser
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsUserHidden
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/module/mod185.stderr
- + testsuite/tests/th/T27013th.hs
- testsuite/tests/th/all.T
- utils/haddock/haddock-api/src/Haddock/Interface.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/460a1b7d88f04447da710ca22e726c5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/460a1b7d88f04447da710ca22e726c5…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/spj-reinstallable-base2] Allow GHC.Essentials to be hidden
by sheaf (＠sheaf) 06 Aug '26
by sheaf (＠sheaf) 06 Aug '26
06 Aug '26
sheaf pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC
Commits:
6274fc7c by sheaf at 2026-08-06T15:17:50+02:00
Allow GHC.Essentials to be hidden
This commit overhauls several aspects of the known entity handling,
in order to allow GHC.Essentials to be hidden without a proliferation
of special cases in the compiler.
The main contribution is to introduce the 'ImportEdge' datatype which
cleans up a lot of ad-hoc handling relating to 'ModSummary', fixing #27603.
This allows us to reduce duplication, e.g. by having Backpack reuse
'mkImportEdges' instead of replicating the "add implicit imports" logic.
It also makes it easier to avoid undesirable edge cases (such as making
sure that the Template Haskell 'reifyModule' function does not leak
the implicit GHC.Essentials import).
Other changes:
- Cache the result of looking up GHC.Essentials (in TcM and DsM
environments) to avoid redundant work.
This reduces allocations on LinkableUsage01 and hard_hole_fits.
- Properly look up known entities for StaticPointers like we do for
other known entities everywhere else. This allows e.g. modules in
ghc-internal to use -XStaticPointers.
- When using multiple home units, we are now careful to handle the
situation in which we may have multiple GHC.Essentials modules
around. See the new tests under 'driver/multipleHomeUnits'.
- - - - -
86 changed files:
- compiler/GHC.hs
- compiler/GHC/Builtin.hs
- compiler/GHC/Builtin/Modules.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Config/Tidy.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Errors/Ppr.hs
- compiler/GHC/Iface/Errors/Types.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Plugin.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/External.hs
- compiler/GHC/Unit/External/ModuleOrigin.hs
- compiler/GHC/Unit/External/Providers.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/Types.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- libraries/base/base.cabal.in
- testsuite/driver/testutil.py
- testsuite/tests/cabal/T12485/Makefile
- testsuite/tests/driver/T27013e/T27013e.hs
- testsuite/tests/driver/T27013e/T27013e.stderr
- testsuite/tests/driver/T27013f/T27013f.hs
- testsuite/tests/driver/T27013f/T27013f.stderr
- + testsuite/tests/driver/T27013g/T27013g.hs
- + testsuite/tests/driver/T27013g/all.T
- + testsuite/tests/driver/T27013h/GHC/Essentials.hs
- + testsuite/tests/driver/T27013h/T27013h.stderr
- + testsuite/tests/driver/T27013h/all.T
- + testsuite/tests/driver/T27013h/unitT27013h
- + testsuite/tests/driver/T27013i/T27013i.hs
- + testsuite/tests/driver/T27013i/T27013i.stderr
- + testsuite/tests/driver/T27013i/all.T
- testsuite/tests/driver/multipleHomeUnits/Makefile
- testsuite/tests/driver/multipleHomeUnits/all.T
- + testsuite/tests/driver/multipleHomeUnits/essentials-home/GHC/Essentials.hs
- + testsuite/tests/driver/multipleHomeUnits/essentials-order-base/B.hs
- + testsuite/tests/driver/multipleHomeUnits/essentials-order-user/U.hs
- + testsuite/tests/driver/multipleHomeUnits/essentials-user/M.hs
- testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stderr
- + testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_essentials.stdout
- + testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_essentials_order.stderr
- + testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_essentials_recomp.stdout
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsHome
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsHomeHidden
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsOrderBase
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsOrderUser
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsUser
- + testsuite/tests/driver/multipleHomeUnits/unitEssentialsUserHidden
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/module/mod185.stderr
- + testsuite/tests/th/T27013th.hs
- testsuite/tests/th/all.T
- utils/haddock/haddock-api/src/Haddock/Interface.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6274fc7c7b58d41fbf91fc4d4f3e995…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6274fc7c7b58d41fbf91fc4d4f3e995…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/jeltsch/ghc-9-14-building-base] Make .gitlab/base-ci.sh` executable
by Wolfgang Jeltsch (＠jeltsch) 06 Aug '26
by Wolfgang Jeltsch (＠jeltsch) 06 Aug '26
06 Aug '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/ghc-9-14-building-base at Glasgow Haskell Compiler / GHC
Commits:
409524ee by Wolfgang Jeltsch at 2026-08-06T15:04:20+03:00
Make .gitlab/base-ci.sh` executable
- - - - -
1 changed file:
- .gitlab/base-ci.sh
Changes:
=====================================
.gitlab/base-ci.sh
=====================================
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/409524ee2ee85f108fa73be9c30c9e3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/409524ee2ee85f108fa73be9c30c9e3…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Add tracing to find out the suffix for `emsdk` tests
by Wolfgang Jeltsch (＠jeltsch) 06 Aug '26
by Wolfgang Jeltsch (＠jeltsch) 06 Aug '26
06 Aug '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC
Commits:
4c9c91ab by Wolfgang Jeltsch at 2026-08-06T14:53:28+03:00
Add tracing to find out the suffix for `emsdk` tests
- - - - -
1 changed file:
- testsuite/driver/testlib.py
Changes:
=====================================
testsuite/driver/testlib.py
=====================================
@@ -3486,6 +3486,9 @@ def find_expected_file(name: TestName, suff: str, way: WayName) -> Path:
for ws in ['-ws-' + config.wordsize, '']
for way_ext in ['-' + way, '']]
+ if name == 'show-bytestring-vanilla':
+ print(files)
+
for f in files:
if in_srcdir(f).exists():
return f
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c9c91ab887a5e2f216f8a010aa2078…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c9c91ab887a5e2f216f8a010aa2078…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/T27557] Fix three bugs related to required type args and INLINE pragmas
by Simon Peyton Jones (＠simonpj) 06 Aug '26
by Simon Peyton Jones (＠simonpj) 06 Aug '26
06 Aug '26
Simon Peyton Jones pushed to branch wip/T27557 at Glasgow Haskell Compiler / GHC
Commits:
d373dba2 by Simon Peyton Jones at 2026-08-06T12:47:21+01:00
Fix three bugs related to required type args and INLINE pragmas
* `GHC.Core.Opt.Arity.mkEtaForAllMCo` got the visibility flags back to front,
leading to a Lint error (#27557)
* The arity in an InlineSaturation is the VisArity not the Arity; the
two can differ when we have "required" type arguments. This made the
INLINE pragma argument counting go wrong in `makeCorePair` (#27590).
* When a simple binding has a type signature, we take special path in `tcPolyCheck`,
leading to an outer `AbsBinds` that has no dictionaries, even when the binding
is in fact overloaded. That confused the inline-arity computation in
`makeCorePair` (#27589).
The latter two are fixed using the new function `GHC.HsToCore.Binds.findSatArity`.
That actually simplifies the API of `makeCorePair`, which is nice.
The first bug is fixed by swapping the visiblity flags in
`GHC.Core.Opt.Arity.mkEtaForAllMCo`
Getting the INLINE behaviour right led to some perf changes:
* Runtime /halved/ on T7954 due to better specialisation
* Compile time increased by 6% in T21839c because a bit more inlining
happened, as it always should have done.
* For some reason compile-time max-bytes-used dropped by 30% on
T27336, but only on one build configuration; and it increased
on LinkableUsage02 by 6% on another configuration
Geometric mean effect on our compile time benchmarks is +0.1%.
Metric Decrease:
T27336
T7954
Metric Increase:
LinkableUsage02
T21839c
- - - - -
21 changed files:
- + changelog.d/T27557
- + changelog.d/T27589
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Types/Arity.hs
- compiler/GHC/Types/InlinePragma.hs
- compiler/GHC/Types/Var.hs
- libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr
- libraries/base/tests/perf/ElemFusionUnknownList_O2.stderr
- + testsuite/tests/simplCore/should_compile/T27589.hs
- + testsuite/tests/simplCore/should_compile/T27589.stderr
- + testsuite/tests/simplCore/should_compile/T27590.hs
- + testsuite/tests/simplCore/should_compile/T27590.stderr
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/T27557.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
changelog.d/T27557
=====================================
@@ -0,0 +1,8 @@
+section: compiler
+issues: #27577
+mrs: !16433
+synopsis:
+ Fix a Core Lint error involving RequiredTypeArguments
+description:
+ Fixes an issue with a coercion being used for eta expansion storing
+ the wrong visibility information, which caused a Core Lint error.
=====================================
changelog.d/T27589
=====================================
@@ -0,0 +1,10 @@
+section: compiler
+issues: #27589 #27590
+mrs: !16433
+synopsis:
+ Fixes to arity computations
+description:
+ The arity computation for INLINE pragmas now correctly takes into
+ account required type arguments. Separately, the arity computation
+ in ``tcPolyCheck`` now consistently handles dictionary arguments, fixing
+ a short-cut codepath which didn't
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -2370,11 +2370,15 @@ mkEtaForAllMCo (Bndr tcv vis) ty mco
| otherwise -> mk_fco (mkRepReflCo ty)
MCo co -> mk_fco co
where
- mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co)
+ mk_fco co = MCo (mkForAllCo tcv coreTyLamForAllTyFlag vis MRefl co)
-- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly
-- the (EtaInfo Invariant). (sym co) wraps a lambda that always has
-- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core]
-- in GHC.Core.TyCo.Rep
+ --
+ -- Orientation: remember, the output of mkEtaForAllCo goes into an `EI bs mco`,
+ -- and is SymCo'd in `etaInfoAbs`. Hence the orientation of the visibility
+ -- flags. A bit of a brain-strain (#27557).
{-
************************************************************************
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1687,10 +1687,11 @@ isSingletonMatchGroup matches
| otherwise
= False
-matchGroupArity :: MatchGroup (GhcPass id) body -> Arity
+matchGroupVisArity :: MatchGroup (GhcPass id) body -> VisArity
-- This is called before type checking, when mg_arg_tys is not set
-matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts]
-matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1)
+-- Returns the "visible arity" of the MatchGroup i.e. including required type arguments.
+matchGroupVisArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts]
+matchGroupVisArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1)
hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -69,7 +69,7 @@ import GHC.Types.InlinePragma
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Types.Var( EvVar, mkLocalVar )
+import GHC.Types.Var( EvVar, mkLocalVar, isRuntimePiTyBinder )
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Unique.Set( nonDetEltsUniqSet )
@@ -196,7 +196,7 @@ dsHsBind dflags (VarBind { var_id = var
= do { core_expr <- dsLExpr expr
-- Dictionary bindings are always VarBinds,
-- so we only need do this here
- ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr
+ ; let core_bind@(id,_) = makeCorePair dflags var False core_expr
force_var = if xopt LangExt.Strict dflags
then [id]
else []
@@ -211,11 +211,11 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
; let body' = mkOptTickBox tick body
rhs = core_wrap (mkLams args body')
- core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
+ core_binds@(id,_) = makeCorePair dflags fun False rhs
force_var
-- Bindings are strict when -XStrict is enabled
| xopt LangExt.Strict dflags
- , matchGroupArity matches == 0 -- no need to force lambdas
+ , matchGroupVisArity matches == 0 -- no need to force lambdas
= [id]
| isBangedHsBind b
= [id]
@@ -303,7 +303,7 @@ dsAbsBinds dflags tyvars dicts exports
; let global_id' = addIdSpecialisations global_id rules
main_bind = makeCorePair dflags global_id'
(isDefaultMethod prags)
- (dictArity dicts) rhs
+ rhs
; return (force_vars', fromOL spec_binds ++ [main_bind]) } }
@@ -386,7 +386,7 @@ dsAbsBinds dflags tyvars dicts exports
mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id
`orElse` lcl_id
in
- makeCorePair dflags lcl_w_inline False 0 rhs
+ makeCorePair dflags lcl_w_inline False rhs
inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
-- the inline pragma from the source
@@ -437,9 +437,9 @@ dsAbsBinds dflags tyvars dicts exports
-- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal`
-- using this information.
------------------------
-makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
+makeCorePair :: DynFlags -> Id -> Bool -> CoreExpr
-> (Id, CoreExpr)
-makeCorePair dflags gbl_id is_default_method dict_arity rhs
+makeCorePair dflags gbl_id is_default_method rhs
| is_default_method -- Default methods are *always* inlined
-- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance
= (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs)
@@ -456,22 +456,43 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
inline_prag = idInlinePragma gbl_id
inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs
inline_pair
- | AppliedToAtLeast arity <- inlinePragmaSaturation inline_prag
+ | AppliedToAtLeast vis_arity <- inlinePragmaSaturation inline_prag
-- Add an Unfolding for an INLINE (but not for NOINLINE)
-- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
- , let real_arity = dict_arity + arity
- -- NB: The arity passed to mkInlineUnfoldingWithArity
- -- must take account of the dictionaries
- = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs
- , etaExpand real_arity rhs)
+ , let runtime_arity = findSatArity vis_arity (idType gbl_id)
+ -- NB: runtime_arity: the arity passed to mkInlineUnfoldingWithArity
+ -- must take account of dictionaries and required type args
+ = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc
+ runtime_arity rhs
+ , etaExpand runtime_arity rhs)
| otherwise
= pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
(gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs)
-dictArity :: [Var] -> Arity
--- Don't count coercion variables in arity
-dictArity dicts = count isId dicts
+findSatArity :: VisArity -> Type -> Arity
+-- Given the VisArity, find the value Arity of the function.
+-- This is the number of runtime-value arguments the function must be applied
+-- to before the INLINE pragma fires and inlines the function
+-- We must:
+-- add one for each invisible dictionary arg; and
+-- subtract one for each required type argment
+findSatArity vis_arity ty
+ = go vis_arity pi_bndrs
+ where
+ (pi_bndrs, _) = splitPiTys ty
+
+ go vis_arity (bndr : bndrs)
+ | isInvisiblePiTyBinder bndr = add_bndr bndr (go vis_arity bndrs)
+ | vis_arity == 0 = 0
+ | otherwise = add_bndr bndr (go (vis_arity-1) bndrs)
+ go vis_arity []
+ | vis_arity == 0 = 0
+ | otherwise = pprPanic "findSatArity" (ppr vis_arity $$ ppr ty)
+
+ add_bndr :: PiTyBinder -> Arity -> Arity
+ add_bndr bndr ar | isRuntimePiTyBinder bndr = ar+1
+ | otherwise = ar
{-
Note [Desugaring AbsBinds]
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -737,21 +737,21 @@ Call @match@ with all of this information!
-- There are three possible cases for matchWrapper's scrutinees argument:
--
-- 1. Nothing Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee
--- The MatchGroup may have matchGroupArity of 0 or more. Examples:
--- f p1 q1 = ... -- matchGroupArity 2
+-- The MatchGroup may have matchGroupVisArity of 0 or more. Examples:
+-- f p1 q1 = ... -- matchGroupVisArity 2
-- f p2 q2 = ...
--
-- \cases | g1 -> ... -- matchGroupArity 0
-- | g2 -> ...
--
-- 2. Just [e] Used for HsCase, RecordUpd; exactly one scrutinee
--- The MatchGroup has matchGroupArity of exactly 1. Example:
--- case e of p1 -> e1 -- matchGroupArity 1
+-- The MatchGroup has matchGroupVisArity of exactly 1. Example:
+-- case e of p1 -> e1 -- matchGroupVisArity 1
-- p2 -> e2
--
-- 3. Just es Used for HsCmdLamCase; zero or more scrutinees
-- The MatchGroup has matchGroupArity of (length es). Example:
--- \cases p1 q1 -> returnA -< ... -- matchGroupArity 2
+-- \cases p1 q1 -> returnA -< ... -- matchGroupVisArity 2
-- p2 q2 -> ...
matchWrapper
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -288,7 +288,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
-- We don't want to generate code for blacklisted positions
-- We don't want redundant ticks on simple pattern bindings
-- We don't want to tick non-exported bindings in TickExportedFunctions
- let simple = matchGroupArity matches == 0
+ let simple = matchGroupVisArity matches == 0
-- A binding is a "simple pattern binding" if it is a
-- funbind with zero patterns
toplev = null decl_path
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -808,7 +808,7 @@ checkMonomorphismRestriction mbis lbinds
restricted (VarBind { var_ext = x }) = dataConCantHappen x
restricted b@(PatSynBind {}) = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
- restricted_match mg = matchGroupArity mg == 0
+ restricted_match mg = matchGroupVisArity mg == 0
-- No args => like a pattern binding
-- Some args => a function binding
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -599,26 +599,26 @@ mkPragEnv sigs binds
Nothing -> sig -- See Note [Pattern synonym inline arity]
-- ar_env maps a local to the arity of its definition
- ar_env :: NameEnv Arity
- ar_env = foldr lhsBindArity emptyNameEnv binds
+ ar_env :: NameEnv VisArity
+ ar_env = foldr lhsBindVisArity emptyNameEnv binds
-addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn
+addInlinePragArity :: VisArity -> LSig GhcRn -> LSig GhcRn
addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl))
addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl))
addInlinePragArity ar (L l (SpecSigE n x e inl)) = L l (SpecSigE n x e (add_inl_arity ar inl))
addInlinePragArity _ sig = sig
-add_inl_arity :: Arity -> InlinePragma GhcRn -> InlinePragma GhcRn
+add_inl_arity :: VisArity -> InlinePragma GhcRn -> InlinePragma GhcRn
add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec })
| Inline {} <- inl_spec -- Add arity only for real INLINE pragmas, not INLINABLE
= prag `setInlinePragmaSaturation` AppliedToAtLeast ar
| otherwise
= prag
-lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
-lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
- = extendNameEnv env (unLoc id) (matchGroupArity ms)
-lhsBindArity _ env = env -- PatBind/VarBind
+lhsBindVisArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
+lhsBindVisArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
+ = extendNameEnv env (unLoc id) (matchGroupVisArity ms)
+lhsBindVisArity _ env = env -- PatBind/VarBind
-----------------
=====================================
compiler/GHC/Types/Arity.hs
=====================================
@@ -84,7 +84,14 @@ like Haskell, there is more than one way to count those arguments.
forall a b. (Num a, Ord b) => a -> b -> a has arity <= 4
* `VisArity` is the syntactic notion of arity. It is the number of /visible/
- arguments, i.e. arguments that occur visibly in the source code.
+ arguments, i.e. arguments that occur visibly in the source code. For example:
+ f1 :: forall a. a -> a
+ f1 x = x
+ f2 :: forall a -> a -> a
+ f2 t x = x
+ Both have Arity 1 because there is one /value/ argument.
+ But f1 has VisArity 1 while f2 has VisArity 2, becuase f2 has a required
+ type argument.
In a function call `f x y z`, we can confidently say that f's vis-arity >= 3,
simply because we see three arguments [x,y,z]. We write (>=) rather than (==)
=====================================
compiler/GHC/Types/InlinePragma.hs
=====================================
@@ -104,7 +104,7 @@ import GHC.Prelude
import GHC.Data.FastString
import GHC.Hs.Extension
-import GHC.Types.Arity (Arity)
+import GHC.Types.Arity (VisArity)
import GHC.Types.SourceText (SourceText(..))
import GHC.Utils.Binary
import GHC.Utils.Outputable
@@ -125,12 +125,13 @@ infixl 1 `setInlinePragmaActivation`,
-- | The arity /at which to/ inline a function.
-- This may differ from the function's syntactic arity.
data InlineSaturation
- = AppliedToAtLeast !Arity
+ = AppliedToAtLeast !VisArity
-- ^ Inline only when applied to @n@ explicit
- -- (non-type, non-dictionary) arguments.
+ -- (required type or value) arguments.
--
-- That is, 'AppliedToAtLeast' describes the number of
-- *source-code* arguments the thing must be applied to.
+
| AnySaturation
-- ^ There does not exist an explicit number of arguments
-- that the inlining process should be applied to.
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -82,7 +82,7 @@ module GHC.Types.Var (
-- * PiTyBinder
PiTyBinder(..), PiTyVarBinder,
isInvisiblePiTyBinder, isInvisibleAnonPiTyBinder,
- isVisiblePiTyBinder,
+ isVisiblePiTyBinder, isRuntimePiTyBinder,
isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder,
namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType,
@@ -757,7 +757,12 @@ instance NamedThing tv => NamedThing (VarBndr tv flag) where
-- not. See Note [PiTyBinders]
data PiTyBinder
= Named ForAllTyBinder -- A type-lambda binder, with a ForAllTyFlag
- | Anon (Scaled Type) FunTyFlag -- A term-lambda binder. Type here can be CoercionTy.
+ -- Erased (not passed at runtime) if the binder is
+ -- a type variable; not erased if coercion variable
+
+ | Anon (Scaled Type) FunTyFlag -- A term-lambda binder, passing a runtime value
+ -- The argument can be a constraint (incl dictionary)
+ -- or an ordinary value
-- The arrow is described by the FunTyFlag
deriving Data
@@ -792,6 +797,12 @@ namedPiTyBinder_maybe :: PiTyBinder -> Maybe TyCoVar
namedPiTyBinder_maybe (Named tv) = Just $ binderVar tv
namedPiTyBinder_maybe _ = Nothing
+isRuntimePiTyBinder :: PiTyBinder -> Bool
+isRuntimePiTyBinder (Anon {}) = True -- Always passed at runtime
+isRuntimePiTyBinder (Named (Bndr tcv _)) = isCoVar tcv
+ -- isCoVar: see Note [Why ForAllTy can quantify over a coercion variable]
+ -- and Note [Unused coercion variable in ForAllTy], in GHC.Core.TyCo.Rep
+
-- | Does this binder bind a variable that is /not/ erased? Returns
-- 'True' for anonymous binders.
isAnonPiTyBinder :: PiTyBinder -> Bool
@@ -817,7 +828,7 @@ piTyBinderType (Named (Bndr tv _)) = varType tv
piTyBinderType (Anon ty _) = scaledThing ty
{- Note [PiTyBinders]
-~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~
But a type like
forall a. Maybe a -> forall b. (a,b) -> b
@@ -830,14 +841,18 @@ argument to a Pi-type. GHC Core currently supports two different
Pi-types:
* Anon ty1 fun_flag: a non-dependent function type,
- written with ->, e.g. ty1 -> ty2
- represented as FunTy ty1 ty2. These are
- lifted to Coercions with the corresponding FunCo.
+ written with ->, e.g. ty1 -> ty2
+ represented as FunTy ty1 ty2.
+
+ See wrinkle (PIT1)
+
+ These are lifted to Coercions with the corresponding FunCo.
+
+ * Named (Var tcv forall_flag): a dependent polytype,
+ written with forall, e.g. forall (a:*). ty
+ represented as ForAllTy (Bndr a v) ty
- * Named (Var tv forall_flag)
- A dependent compile-time-only polytype,
- written with forall, e.g. forall (a:*). ty
- represented as ForAllTy (Bndr a v) ty
+ See wrinkle (PIT2)
Both forms of Pi-types classify terms/types that take an argument. In other
words, if `x` is either a function or a polytype, `x arg` makes sense
@@ -845,12 +860,16 @@ words, if `x` is either a function or a polytype, `x arg` makes sense
Wrinkles
-* The Anon constructor of PiTyBinder contains a FunTyFlag. Since
+(PIT1) The Anon constructor of PiTyBinder contains a FunTyFlag. Since
the PiTyBinder really only describes the /argument/ it should perhaps
only have a TypeOrConstraint rather than a full FunTyFlag. But it's
very convenient to have the full FunTyFlag, say in mkPiTys, so that's
what we do.
+(PIT2) The `tcv` in `Named (Var tcv forall_flag) is usually a type variable
+ but can exceptionally be a coercion variable: see
+ Note [Why ForAllTy can quantify over a coercion variable].
+ If it's a type variable it will be erased; if coercion variable it will not.
Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr
=====================================
@@ -43,17 +43,17 @@ fusionElemFilter
jump go1 eta
fusionNotElemConcatMap
- = \ x x1 ->
+ = \ x eta ->
joinrec {
go1 ds
= case ds of {
[] -> True;
: y ys ->
- case y of { I# x2 ->
- case x of { I# x3 ->
- case ==# x3 (+# x2 1#) of {
+ case y of { I# x1 ->
+ case x of { I# x2 ->
+ case ==# x2 (+# x1 1#) of {
__DEFAULT ->
- case ==# x3 (+# x2 2#) of {
+ case ==# x2 (+# x1 2#) of {
__DEFAULT -> jump go1 ys;
1# -> False
};
@@ -62,20 +62,20 @@ fusionNotElemConcatMap
}
}
}; } in
- jump go1 x1
+ jump go1 eta
fusionElemConcatMap
- = \ x x1 ->
+ = \ x eta ->
joinrec {
go1 ds
= case ds of {
[] -> False;
: y ys ->
- case y of { I# x2 ->
- case x of { I# x3 ->
- case ==# x3 (+# x2 1#) of {
+ case y of { I# x1 ->
+ case x of { I# x2 ->
+ case ==# x2 (+# x1 1#) of {
__DEFAULT ->
- case ==# x3 (+# x2 2#) of {
+ case ==# x2 (+# x1 2#) of {
__DEFAULT -> jump go1 ys;
1# -> True
};
@@ -84,7 +84,7 @@ fusionElemConcatMap
}
}
}; } in
- jump go1 x1
+ jump go1 eta
fusionNotElemMap
= \ x eta ->
=====================================
libraries/base/tests/perf/ElemFusionUnknownList_O2.stderr
=====================================
@@ -77,25 +77,25 @@ fusionElemFilter
jump go1 eta
fusionNotElemConcatMap
- = \ x x1 ->
- case x1 of {
+ = \ x eta ->
+ case eta of {
[] -> True;
: y ys ->
- case y of { I# x2 ->
- case x of { I# x3 ->
- case ==# x3 (+# x2 1#) of {
+ case y of { I# x1 ->
+ case x of { I# x2 ->
+ case ==# x2 (+# x1 1#) of {
__DEFAULT ->
- case ==# x3 (+# x2 2#) of {
+ case ==# x2 (+# x1 2#) of {
__DEFAULT ->
joinrec {
go1 ds
= case ds of {
[] -> True;
: y1 ys1 ->
- case y1 of { I# x4 ->
- case ==# x3 (+# x4 1#) of {
+ case y1 of { I# x3 ->
+ case ==# x2 (+# x3 1#) of {
__DEFAULT ->
- case ==# x3 (+# x4 2#) of {
+ case ==# x2 (+# x3 2#) of {
__DEFAULT -> jump go1 ys1;
1# -> False
};
@@ -113,25 +113,25 @@ fusionNotElemConcatMap
}
fusionElemConcatMap
- = \ x x1 ->
- case x1 of {
+ = \ x eta ->
+ case eta of {
[] -> False;
: y ys ->
- case y of { I# x2 ->
- case x of { I# x3 ->
- case ==# x3 (+# x2 1#) of {
+ case y of { I# x1 ->
+ case x of { I# x2 ->
+ case ==# x2 (+# x1 1#) of {
__DEFAULT ->
- case ==# x3 (+# x2 2#) of {
+ case ==# x2 (+# x1 2#) of {
__DEFAULT ->
joinrec {
go1 ds
= case ds of {
[] -> False;
: y1 ys1 ->
- case y1 of { I# x4 ->
- case ==# x3 (+# x4 1#) of {
+ case y1 of { I# x3 ->
+ case ==# x2 (+# x3 1#) of {
__DEFAULT ->
- case ==# x3 (+# x4 2#) of {
+ case ==# x2 (+# x3 2#) of {
__DEFAULT -> jump go1 ys1;
1# -> True
};
=====================================
testsuite/tests/simplCore/should_compile/T27589.hs
=====================================
@@ -0,0 +1,9 @@
+module T28589 where
+
+wombat :: Num a => a -> a
+{-# INLINE wombat #-}
+wombat x = x+x*x
+
+g :: Num a => [a] -> [a]
+g ys = map wombat ys
+ -- wombat should not inline here
=====================================
testsuite/tests/simplCore/should_compile/T27589.stderr
=====================================
@@ -0,0 +1,3 @@
+wombat [InlPrag=INLINE (sat-args=1)] :: forall a. Num a => a -> a
+wombat
+ map @a @a (wombat @a $dNum) ys
=====================================
testsuite/tests/simplCore/should_compile/T27590.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE RequiredTypeArguments #-}
+
+module Foo where
+
+wombat :: forall a -> a -> Maybe a
+{-# INLINE wombat #-}
+wombat t x = Just x
+
+g y = wombat Int (y+y)
+ -- wombat /should/ inline here
=====================================
testsuite/tests/simplCore/should_compile/T27590.stderr
=====================================
@@ -0,0 +1,2 @@
+wombat [InlPrag=INLINE (sat-args=2)] :: forall a -> a -> Maybe a
+wombat
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -609,3 +609,5 @@ test('T4081', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-a
test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O'])
test('T27296', [], makefile_test, ['T27296'])
test('T27296b', [], makefile_test, ['T27296b'])
+test('T27589', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T27590', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
=====================================
testsuite/tests/typecheck/should_compile/T27557.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE RequiredTypeArguments #-}
+
+module RequiredTypeArgumentsMkSymCo where
+
+import Data.Kind (Type)
+
+f :: forall a . forall (b :: Type) -> a -> a
+f t = id
+{-# INLINE f #-}
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -968,4 +968,4 @@ test('T24464', normal, compile, [''])
test('ExpansionQLIm', normal, compile, [''])
test('T23135', normal, compile, [''])
test('LazyFieldAnnotations', normal, compile, [''])
-
+test('T27557', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d373dba276d5cd97c4cb3a218d5314d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d373dba276d5cd97c4cb3a218d5314d…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: hie files: Dump the type table when dumping with -ddump-hie
by Marge Bot (＠marge-bot) 06 Aug '26
by Marge Bot (＠marge-bot) 06 Aug '26
06 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a10cb52a by Zubin Duggal at 2026-08-06T07:29:26-04:00
hie files: Dump the type table when dumping with -ddump-hie
- - - - -
a745b443 by Zubin Duggal at 2026-08-06T07:29:26-04:00
hie files: Take evidence for quantified constraints into account when saving evidence terms to the hie ast
Fixes #25709
- - - - -
5f17ab12 by Simon Jakobi at 2026-08-06T07:29:28-04:00
testsuite: fix stale paths for the ghc-config build artifacts
ghc-config.hs moved from testsuite/mk/ to testsuite/ghc-config/ in
6c7a49139c, but the .gitignore entry and the clean rule still referred to
the old location. As a result the compiled ghc-config binary, which
boilerplate.mk rebuilds on every make-driven test run, showed up as an
untracked file and was never cleaned.
Assisted-by: Claude Opus 5
- - - - -
fecb9282 by Simon Peyton Jones at 2026-08-06T07:29:28-04:00
Documentation only
...driven by my investigation of #27591
- - - - -
1cab497c by Alan Zimmerman at 2026-08-06T07:29:29-04:00
EPA: Replace AnnPragma with individual types
We introduced AnnPragma as a common type for all pragma usages wrapped
in LocatedP / SrcSpanAnnP. Now that those are gone, and the AnnPragma
moved into the TTG points for the given items, we can ensure that each
carries only the annotations it needs.
So we remove AnnPragma, and in its place bring in
AnnCType
AnnWarningTxt
AnnOverlap
AnnAnnDecl
AnnPragSCC
- - - - -
20 changed files:
- compiler/GHC/Core/Class.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Decls/Overlap.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Unit/Module/Warnings.hs
- testsuite/.gitignore
- testsuite/Makefile
- testsuite/tests/hiefile/should_compile/T24493.stderr
- + testsuite/tests/hiefile/should_run/T25709.hs
- + testsuite/tests/hiefile/should_run/T25709.stdout
- testsuite/tests/hiefile/should_run/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Core/Class.hs
=====================================
@@ -84,9 +84,9 @@ data Class
-- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
type FunDep a = ([a],[a])
-type ClassOpItem = (Id, DefMethInfo)
- -- Selector function; contains unfolding
- -- Default-method info
+type ClassOpItem = ( Id -- Dictionary selector function
+ -- See Note [Dictionary selectors]
+ , DefMethInfo) -- Default-method info
type DefMethInfo = Maybe (Name, DefMethSpec Type)
-- Nothing No default method
@@ -164,7 +164,19 @@ classMinimalDef :: Class -> ClassMinimalDef
classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d
classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction
-{-
+{- Note [Dictionary selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Each `ClassOpItem` stores a dictionary selector `Id`:
+
+* The type of the selector is always closed, and has form
+ forall a1..an. C a1 .. an => blah
+ where `a1..an` are the class variables, and
+ `blah` is the method type.
+ See GHC.Types.Id.Make.mkDictSelId, which constructs them.
+
+* The selector has no unfolding, but one RULE.
+ See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance
+
Note [Associated type defaults]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following is an example of associated type defaults:
=====================================
compiler/GHC/Driver/Main/Passes.hs
=====================================
@@ -92,7 +92,7 @@ import GHC.Iface.Make
import GHC.Iface.Recomp
import GHC.Iface.Tidy
import GHC.Iface.Ext.Ast ( mkHieFile )
-import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
+import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module, hie_types )
import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
@@ -167,7 +167,7 @@ import GHC.Data.StringBuffer
import GHC.Data.Maybe
import qualified GHC.Data.Strict as Strict
-
+import qualified Data.Array as A
import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
import Control.Monad
@@ -332,7 +332,10 @@ extract_renamed_stuff mod_summary tc_result = do
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
let out_file = ml_hie_file $ ms_location mod_summary
liftIO $ writeHieFile out_file hieFile
- liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
+ let hie_doc =
+ ppr (hie_asts hieFile)
+ $+$ ppr (A.assocs $ hie_types hieFile)
+ liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell hie_doc
-- Validate HIE files
when (gopt Opt_ValidateHie dflags) $ do
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1528,7 +1528,7 @@ instance OutputableBndrId p
************************************************************************
-}
-type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText)
+type instance XHsAnnotation (GhcPass _) = (AnnAnnDecl, SourceText)
type instance XXAnnDecl (GhcPass _) = DataConCantHappen
instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where
=====================================
compiler/GHC/Hs/Decls/Overlap.hs
=====================================
@@ -26,7 +26,7 @@ import GHC.Prelude
import GHC.Hs.Extension
-import GHC.Parser.Annotation ( AnnPragma )
+import GHC.Parser.Annotation ( AnnOverlap )
import Language.Haskell.Syntax.Decls.Overlap
import Language.Haskell.Syntax.Extension
@@ -67,8 +67,8 @@ instance NFData OverlapFlag where
instance Outputable OverlapFlag where
ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
-type instance XOverlapMode GhcPs = (SourceText, AnnPragma)
-type instance XOverlapMode GhcRn = (SourceText, AnnPragma)
+type instance XOverlapMode GhcPs = (SourceText, AnnOverlap)
+type instance XOverlapMode GhcRn = (SourceText, AnnOverlap)
type instance XOverlapMode GhcTc = SourceText
type instance XXOverlapMode (GhcPass _) = DataConCantHappen
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -612,7 +612,7 @@ instance NoAnn AnnFunRhs where
-- ---------------------------------------------------------------------
-type instance XSCC (GhcPass _) = (AnnPragma, SourceText)
+type instance XSCC (GhcPass _) = (AnnPragSCC, SourceText)
type instance XXPragE (GhcPass _) = DataConCantHappen
type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -159,6 +159,18 @@ data HieType a
| HCoercionTy
deriving (Functor, Foldable, Traversable, Eq)
+instance Outputable a => Outputable (HieType a) where
+ ppr (HTyVarTy name) = ppr name
+ ppr (HAppTy fun arg) = parens $ ppr fun <+> ppr arg
+ ppr (HTyConApp tc args) = parens $ ppr tc <+> ppr args
+ ppr (HForAllTy ((name, ty), flag) body) =
+ text "forall" <+> ppr flag <+> ppr name O.<> text ":" <+> ppr ty O.<> text "." <+> ppr body
+ ppr (HFunTy mult arg res) = parens $ ppr arg <+> arrow <+> ppr res <+> ppr mult
+ ppr (HQualTy ctxt ty) = parens $ ppr ctxt <+> text "=>" <+> ppr ty
+ ppr (HLitTy lit) = ppr lit
+ ppr (HCastTy ty) = text "cast" <+> ppr ty
+ ppr HCoercionTy = text "<coercion>"
+
type HieTypeFlat = HieType TypeIndex
-- | Roughly isomorphic to the original core 'Type'.
@@ -222,6 +234,10 @@ instance Binary (HieArgs TypeIndex) where
put_ bh (HieArgs xs) = put_ bh xs
get bh = HieArgs <$> get bh
+instance Outputable a => Outputable (HieArgs a) where
+ ppr (HieArgs args) = braces $ hsep $ punctuate comma $ map pprArg args
+ where pprArg (vis, ty) = (if vis then id else parens) (ppr ty)
+
-- A HiePath is just a lexical FastString. We use a lexical FastString to avoid
-- non-determinism when printing or storing HieASTs which are sorted by their
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1473,13 +1473,13 @@ inst_decl :: { LInstDecl GhcPs }
overlap_pragma :: { Maybe (LocatedA (OverlapMode GhcPs)) }
: '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1,
- AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+ AnnOverlap (glR $1) (epTok $2)))) }
| '{-# OVERLAPPING' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1,
- AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+ AnnOverlap (glR $1) (epTok $2)))) }
| '{-# OVERLAPS' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1,
- AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+ AnnOverlap (glR $1) (epTok $2)))) }
| '{-# INCOHERENT' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1,
- AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+ AnnOverlap (glR $1) (epTok $2)))) }
| {- empty -} { Nothing }
deriv_strategy_no_via :: { LDerivStrategy GhcPs }
@@ -1710,13 +1710,13 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs
capi_ctype :: { Maybe (LocatedA (CType GhcPs)) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}'
{% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3)
- (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn)
+ (AnnCType (glR $1) (epTok $4) (glR $2) (glR $3))
(Just (Header (getSTRINGs $2) (getSTRING $2)))
(getSTRING $3)))}
| '{-# CTYPE' STRING '#-}'
{% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2)
- (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn)
+ (AnnCType (glR $1) (epTok $3) noAnn (glR $2))
Nothing (getSTRING $2)))}
| { Nothing }
@@ -2078,11 +2078,11 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
: '{-# DEPRECATED' strings '#-}'
{% fmap Just $ amsA' (sLL $1 $> $
- DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn)
+ DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnWarningTxt (glR $1) (epTok $3) (fst $ unLoc $2))
(snd $ unLoc $2))}
| '{-# WARNING' warning_category strings '#-}'
{% fmap Just $ amsA' (sLL $1 $> $
- WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)
+ WarningTxt (getWARNING_PRAGs $1, AnnWarningTxt (glR $1) (epTok $4) (fst $ unLoc $3))
$2 (snd $ unLoc $3))}
| {- empty -} { Nothing }
@@ -2165,19 +2165,19 @@ stringlist :: { Located (OrdList (LocatedA (WithHsDocIdentifiers (StringLiteral
annotation :: { LHsDecl GhcPs }
: '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation
- (AnnPragma (glR $1) (epTok $4) noAnn noAnn noAnn noAnn noAnn,
+ (AnnAnnDecl (glR $1) (epTok $4) noAnn noAnn,
(getANN_PRAGs $1))
(ValueAnnProvenance $2) $3)) }
| '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->
amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation
- (AnnPragma (glR $1) (epTok $5) noAnn noAnn noAnn (epTok $2) noAnn,
+ (AnnAnnDecl (glR $1) (epTok $5) (epTok $2) noAnn,
(getANN_PRAGs $1))
(TypeAnnProvenance $3) $4)) }
| '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation
- (AnnPragma (glR $1) (epTok $4) noAnn noAnn noAnn noAnn (epTok $2),
+ (AnnAnnDecl (glR $1) (epTok $4) noAnn (epTok $2),
(getANN_PRAGs $1))
ModuleAnnProvenance $3)) }
@@ -3052,12 +3052,12 @@ prag_e :: { Located (HsPragE GhcPs) }
: '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2
; return (sLL $1 $>
(HsPragSCC
- (AnnPragma (glR $1) (epTok $3) noAnn (glR $2) noAnn noAnn noAnn,
+ (AnnPragSCC (glR $1) (epTok $3) (glR $2),
(getSCC_PRAGs $1))
(StringLiteral (getSTRINGs $2) scc)))} }
| '{-# SCC' VARID '#-}' { sLL $1 $>
(HsPragSCC
- (AnnPragma (glR $1) (epTok $3) noAnn (glR $2) noAnn noAnn noAnn,
+ (AnnPragSCC (glR $1) (epTok $3) (glR $2),
(getSCC_PRAGs $1))
(StringLiteral NoSourceText (fastStringToShortText $ getVARID $2))) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -36,7 +36,7 @@ module GHC.Parser.Annotation (
AnnList(..), AnnListBrackets(..),
AnnParen(..),
- AnnPragma(..),
+ AnnCType(..),AnnWarningTxt(..),AnnOverlap(..),AnnAnnDecl(..),AnnPragSCC(..),
AnnBooleanFormula(..),
NameAnn(..), NameAdornment(..),
NoEpAnns(..),
@@ -627,15 +627,40 @@ data NameAdornment
-- | exact print annotation used for capturing the locations of
-- annotations in pragmas.
-data AnnPragma
- = AnnPragma {
- apr_open :: EpaLocation,
- apr_close :: EpToken "#-}",
- apr_squares :: (EpToken "[", EpToken "]"),
- apr_loc1 :: EpaLocation,
- apr_loc2 :: EpaLocation,
- apr_type :: EpToken "type",
- apr_module :: EpToken "module"
+data AnnCType
+ = AnnCType {
+ ac_open :: EpaLocation,
+ ac_close :: EpToken "#-}",
+ ac_loc1 :: EpaLocation,
+ ac_loc2 :: EpaLocation
+ } deriving (Data,Eq)
+
+data AnnWarningTxt
+ = AnnWarningTxt {
+ awt_open :: EpaLocation,
+ awt_close :: EpToken "#-}",
+ awt_squares :: (EpToken "[", EpToken "]")
+ } deriving (Data,Eq)
+
+data AnnOverlap
+ = AnnOverlap {
+ ao_open :: EpaLocation,
+ ao_close :: EpToken "#-}"
+ } deriving (Data,Eq)
+
+data AnnAnnDecl
+ = AnnAnnDecl {
+ ad_open :: EpaLocation,
+ ad_close :: EpToken "#-}",
+ ad_type :: EpToken "type",
+ ad_module :: EpToken "module"
+ } deriving (Data,Eq)
+
+data AnnPragSCC
+ = AnnPragSCC {
+ aps_open :: EpaLocation,
+ aps_close :: EpToken "#-}",
+ aps_loc1 :: EpaLocation
} deriving (Data,Eq)
-- ---------------------------------------------------------------------
@@ -1020,8 +1045,20 @@ instance NoAnn a => NoAnn (AnnList a) where
instance NoAnn NameAnn where
noAnn = NameAnnTrailing []
-instance NoAnn AnnPragma where
- noAnn = AnnPragma noAnn noAnn noAnn noAnn noAnn noAnn noAnn
+instance NoAnn AnnCType where
+ noAnn = AnnCType noAnn noAnn noAnn noAnn
+
+instance NoAnn AnnWarningTxt where
+ noAnn = AnnWarningTxt noAnn noAnn noAnn
+
+instance NoAnn AnnOverlap where
+ noAnn = AnnOverlap noAnn noAnn
+
+instance NoAnn AnnAnnDecl where
+ noAnn = AnnAnnDecl noAnn noAnn noAnn noAnn
+
+instance NoAnn AnnPragSCC where
+ noAnn = AnnPragSCC noAnn noAnn noAnn
instance NoAnn AnnParen where
noAnn = AnnParens noAnn noAnn
@@ -1107,7 +1144,23 @@ instance Outputable AnnListBrackets where
ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c
ppr ListNone = text "ListNone"
-instance Outputable AnnPragma where
- ppr (AnnPragma o c s l ca t m)
- = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr s <+> ppr l
- <+> ppr ca <+> ppr ca <+> ppr t <+> ppr m
+instance Outputable AnnCType where
+ ppr (AnnCType o c l ca)
+ = text "AnnCType" <+> ppr o <+> ppr c <+> ppr l
+ <+> ppr ca <+> ppr ca
+
+instance Outputable AnnWarningTxt where
+ ppr (AnnWarningTxt o c s)
+ = text "AnnWarningTxt" <+> ppr o <+> ppr c <+> ppr s
+
+instance Outputable AnnOverlap where
+ ppr (AnnOverlap o c)
+ = text "AnnOverlap" <+> ppr o <+> ppr c
+
+instance Outputable AnnAnnDecl where
+ ppr (AnnAnnDecl o c t m)
+ = text "AnnAnnDecl" <+> ppr o <+> ppr c <+> ppr t <+> ppr m
+
+instance Outputable AnnPragSCC where
+ ppr (AnnPragSCC o c l)
+ = text "AnnPragSCC" <+> ppr o <+> ppr c <+> ppr l
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -1188,10 +1188,20 @@ bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed
-> RnM (a, FreeNames)
bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
case outer_bndrs of
+
HsOuterImplicit{} ->
+ -- Add an implicit `forall a1..an` at the top, where `a1..an`
+ -- are not-otherwise-in-scope type variables.
+ -- Used when there is no forall, or a /visible/ (forall a -> blah)
+ -- See Note [forall-or-nothing rule] in Language.Haskell.Syntax.Type
rnImplicitTvOccs mb_cls implicit_vars $ \implicit_vars' ->
thing_inside $ HsOuterImplicit { hso_ximplicit = implicit_vars' }
+
HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ -- The type already has an explicit, user-written, invisible forall,
+ -- so do not add an implicit forall
+ -- See Note [forall-or-nothing rule] in Language.Haskell.Syntax.Type
+ --
-- Note: If we pass mb_cls instead of Nothing below, bindLHsTyVarBndrs
-- will use class variables for any names the user meant to bring in
-- scope here. This is an explicit forall, so we want fresh names, not
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -109,7 +109,7 @@ import Data.Data (Data)
import Data.Functor ((<&>))
import Control.DeepSeq (NFData(..))
-import GHC.Parser.Annotation (AnnPragma, noAnn)
+import GHC.Parser.Annotation (AnnCType, noAnn)
{-
************************************************************************
@@ -216,7 +216,7 @@ defaultCType :: String -> CType (GhcPass p)
defaultCType =
CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . packHText
-mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p)
+mkCType :: SourceText -> SourceText -> AnnCType -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p)
mkCType x y ann m =
CType (CTypeGhc x y ann) m
@@ -303,7 +303,7 @@ data StaticTargetGhc = StaticTargetGhc
data CTypeGhc = CTypeGhc
{ cTypeSourceText :: SourceText
, cTypeOtherText :: SourceText
- , cTypeAnn :: AnnPragma
+ , cTypeAnn :: AnnCType
}
deriving (Data, Eq)
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -480,7 +480,7 @@ Therefore there is no loss of generality if we make all selectors unrestricted.
mkDictSelId :: Name -- Name of one of the *value* selectors
-- (dictionary superclass or method)
-> Class -> Id
--- Important: see Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance
+-- See Note [Dictionary selectors]
mkDictSelId name clas
= mkGlobalId (ClassOpId clas terminating) name sel_ty info
where
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -158,8 +158,8 @@ warningTxtSame w1 w2
instance Outputable (InWarningCategory (GhcPass pass)) where
ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt)
-type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma)
-type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma)
+type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnWarningTxt)
+type instance XWarningTxt (GhcPass _) = (SourceText, AnnWarningTxt)
type instance XXWarningTxt (GhcPass _) = DataConCantHappen
type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText)
type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
=====================================
testsuite/.gitignore
=====================================
@@ -72,7 +72,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
# NOTE: to edit this section in Vim, add your ignore annotations some where
# in the list, select the entire section and say ':sort u' to sort it.
-/mk/ghc-config
+/ghc-config/ghc-config
/tests/ado/ado001
/tests/annotations/should_compile/th/build_make
=====================================
testsuite/Makefile
=====================================
@@ -46,5 +46,6 @@ clean distclean maintainer-clean:
$(RM) -f mk/*.o
$(RM) -f mk/*.hi
$(RM) -f mk/ghcconfig*.mk
- $(RM) -f mk/ghc-config mk/ghc-config.exe
+ $(RM) -f ghc-config/ghc-config ghc-config/ghc-config.exe
+ $(RM) -f ghc-config/ghc-config.o ghc-config/ghc-config.hi
$(RM) -f driver/*.pyc
=====================================
testsuite/tests/hiefile/should_compile/T24493.stderr
=====================================
@@ -1,3 +1,4 @@
+
==================== HIE AST ====================
File: T24493.hs
Node@T24493.hs:(1,8)-(3,8): Source: From source
@@ -25,9 +26,10 @@ Node@T24493.hs:(1,8)-(3,8): Source: From source
Node@T24493.hs:3:6-8: Source: From source
{(annotations: {(HsLit, HsExpr)}), (types: [0]),
(identifier info: {})}
-
+
+[(0, (GHC.Internal.Base.String {}))]
Got valid scopes
-Got no roundtrip errors
\ No newline at end of file
+Got no roundtrip errors
=====================================
testsuite/tests/hiefile/should_run/T25709.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE QuantifiedConstraints#-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Main where
+
+import TestUtils
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import Data.Either
+import Data.Maybe
+import Data.Bifunctor (first)
+import GHC.Plugins (moduleNameString, nameStableString, nameOccName, occNameString, isDerivedOccName)
+import GHC.Iface.Ext.Types
+
+
+import Data.Typeable
+
+data Some c where
+ Some :: c a => a -> Some c
+
+extractSome :: (Typeable a, forall x. c x => Typeable x) => Some c -> Maybe a
+extractSome (Some a) = cast a
+
+f :: (forall x. Ord x => Eq [x]) => ()
+f = ()
+{-# NOINLINE f #-}
+
+g :: ()
+g = f
+
+useQC :: forall c a. (c a, forall x. c x => Show x) => a -> String
+useQC x = show x
+
+points :: [(Int,Int)]
+points = [(22,26),(29, 5), (32, 13)]
+
+main = do
+ (df, hf) <- readTestHie "T25709.hie"
+ let refmap = generateReferencesMap $ getAsts $ hie_asts hf
+ traverse (explainEv df hf refmap) points
=====================================
testsuite/tests/hiefile/should_run/T25709.stdout
=====================================
@@ -0,0 +1,110 @@
+==========================
+At point (22,26), we found:
+==========================
+┌
+│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a
+│ is an evidence variable bound by a let, depending on: [$dTypeable]
+│ with scope: LocalScope T25709.hs:22:14-29
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $dTypeable at T25709.hs:22:1-29, of type: Typeable a
+ │ is an evidence variable bound by a HsWrapper
+ │ with scope: LocalScope T25709.hs:22:1-29
+ │ bound at: T25709.hs:22:1-29
+ │ Defined at <no location info>
+ └
+
+┌
+│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a
+│ is an evidence variable bound by a let, depending on: [df, irred]
+│ with scope: LocalScope T25709.hs:22:14-29
+│
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ df at T25709.hs:22:1-29, of type: forall x. c x => Typeable x
+| │ is an evidence variable bound by a HsWrapper
+| │ with scope: LocalScope T25709.hs:22:1-29
+| │ bound at: T25709.hs:22:1-29
+| │ Defined at <no location info>
+| └
+|
+`- ┌
+ │ irred at T25709.hs:22:14-19, of type: c a
+ │ is an evidence variable bound by a let, depending on: [irred]
+ │ with scope: LocalScope T25709.hs:22:14-29
+ │
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ irred at T25709.hs:22:14-19, of type: c a
+ │ is an evidence variable bound by a pattern
+ │ with scope: LocalScope T25709.hs:22:14-29
+ │
+ │ Defined at <no location info>
+ └
+
+==========================
+At point (29,5), we found:
+==========================
+┌
+│ df at T25709.hs:1:1, of type: forall x. Ord x => Eq [x]
+│ is an evidence variable bound by a let, depending on: [$p1Ord,
+│ $fEqList]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ $p1Ord at T25709.hs:1:1, of type: forall a. Ord a => Eq a
+| │ is a usage of an external evidence variable
+| │ Defined in `GHC.Internal.Classes'
+| └
+|
+`- ┌
+ │ $fEqList at T25709.hs:1:1, of type: forall a. Eq a => Eq [a]
+ │ is a usage of an external evidence variable
+ │ Defined in `GHC.Internal.Classes'
+ └
+
+==========================
+At point (32,13), we found:
+==========================
+┌
+│ $dShow at T25709.hs:32:1-16, of type: Show a
+│ is an evidence variable bound by a let, depending on: [df, irred]
+│ with scope: LocalScope T25709.hs:32:1-16
+│ bound at: T25709.hs:32:1-16
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ df at T25709.hs:32:1-16, of type: forall x. c x => Show x
+| │ is an evidence variable bound by a HsWrapper
+| │ with scope: LocalScope T25709.hs:32:1-16
+| │ bound at: T25709.hs:32:1-16
+| │ Defined at <no location info>
+| └
+|
+`- ┌
+ │ irred at T25709.hs:32:1-16, of type: c a
+ │ is an evidence variable bound by a let, depending on: [irred]
+ │ with scope: LocalScope T25709.hs:32:1-16
+ │ bound at: T25709.hs:32:1-16
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ irred at T25709.hs:32:1-16, of type: c a
+ │ is an evidence variable bound by a HsWrapper
+ │ with scope: LocalScope T25709.hs:32:1-16
+ │ bound at: T25709.hs:32:1-16
+ │ Defined at <no location info>
+ └
+
=====================================
testsuite/tests/hiefile/should_run/all.T
=====================================
@@ -8,4 +8,5 @@ test('HieVdq', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUti
test('T23540', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('T23120', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('T24544', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
-test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
\ No newline at end of file
+test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('T25709', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -288,10 +288,6 @@ instance HasTrailing [TrailingAnn] where
trailing a = a
setTrailing _ ts = ts
-instance HasTrailing AnnPragma where
- trailing _ = []
- setTrailing a _ = a
-
instance HasTrailing AnnParen where
trailing _ = []
setTrailing a _ = a
@@ -1559,22 +1555,22 @@ instance ExactPrint (WarningTxt GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do
+ exact (WarningTxt (src, AnnWarningTxt o c (os,cs)) mb_cat ws) = do
o' <- markAnnOpen'' o src "{-# WARNING"
mb_cat' <- markAnnotated mb_cat
os' <- markEpToken os
ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
- return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws')
+ return (WarningTxt (src, AnnWarningTxt o' c' (os',cs')) mb_cat' ws')
- exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do
+ exact (DeprecatedTxt (src, AnnWarningTxt o c (os,cs)) ws) = do
o' <- markAnnOpen'' o src "{-# DEPRECATED"
os' <- markEpToken os
ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
- return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws')
+ return (DeprecatedTxt (src, AnnWarningTxt o' c' (os',cs')) ws')
instance ExactPrint (InWarningCategory GhcPs) where
getAnnotationEntry _ = NoEntryVal
@@ -2251,35 +2247,35 @@ instance ExactPrint (OverlapMode GhcPs) where
setAnnotationAnchor a _ _ _ = a
-- NOTE: NoOverlap is only used in the typechecker
- exact (NoOverlap (src, AnnPragma o c s l1 l2 t m)) = do
+ exact (NoOverlap (src, AnnOverlap o c)) = do
o' <- markAnnOpen'' o src "{-# NO_OVERLAP"
c' <- markEpToken c
- return (NoOverlap (src, AnnPragma o' c' s l1 l2 t m))
+ return (NoOverlap (src, AnnOverlap o' c'))
- exact (Overlappable (src, AnnPragma o c s l1 l2 t m)) = do
+ exact (Overlappable (src, AnnOverlap o c)) = do
o' <- markAnnOpen'' o src "{-# OVERLAPPABLE"
c' <- markEpToken c
- return (Overlappable (src, AnnPragma o' c' s l1 l2 t m))
+ return (Overlappable (src, AnnOverlap o' c'))
- exact (Overlapping (src, AnnPragma o c s l1 l2 t m)) = do
+ exact (Overlapping (src, AnnOverlap o c)) = do
o' <- markAnnOpen'' o src "{-# OVERLAPPING"
c' <- markEpToken c
- return (Overlapping (src, AnnPragma o' c' s l1 l2 t m))
+ return (Overlapping (src, AnnOverlap o' c'))
- exact (Overlaps (src, AnnPragma o c s l1 l2 t m)) = do
+ exact (Overlaps (src, AnnOverlap o c)) = do
o' <- markAnnOpen'' o src "{-# OVERLAPS"
c' <- markEpToken c
- return (Overlaps (src, AnnPragma o' c' s l1 l2 t m))
+ return (Overlaps (src, AnnOverlap o' c'))
- exact (Incoherent (src, AnnPragma o c s l1 l2 t m)) = do
+ exact (Incoherent (src, AnnOverlap o c)) = do
o' <- markAnnOpen'' o src "{-# INCOHERENT"
c' <- markEpToken c
- return (Incoherent (src, AnnPragma o' c' s l1 l2 t m))
+ return (Incoherent (src, AnnOverlap o' c'))
- exact (NonCanonical (src, AnnPragma o c s l1 l2 t m)) = do
+ exact (NonCanonical (src, AnnOverlap o c)) = do
o' <- markAnnOpen'' o src "{-# INCOHERENT"
c' <- markEpToken c
- return (Incoherent (src, AnnPragma o' c' s l1 l2 t m))
+ return (Incoherent (src, AnnOverlap o' c'))
-- ---------------------------------------------------------------------
@@ -2706,7 +2702,7 @@ instance ExactPrint (AnnDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsAnnotation (AnnPragma o c s l1 l2 t m, src) prov e) = do
+ exact (HsAnnotation (AnnAnnDecl o c t m, src) prov e) = do
o' <- markAnnOpen'' o src "{-# ANN"
(t', m', prov') <-
case prov of
@@ -2723,7 +2719,7 @@ instance ExactPrint (AnnDecl GhcPs) where
e' <- markAnnotated e
c' <- markEpToken c
- return (HsAnnotation (AnnPragma o' c' s l1 l2 t' m',src) prov' e')
+ return (HsAnnotation (AnnAnnDecl o' c' t' m',src) prov' e')
-- ---------------------------------------------------------------------
@@ -3146,11 +3142,11 @@ instance ExactPrint (HsPragE GhcPs) where
getAnnotationEntry HsPragSCC{} = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsPragSCC (AnnPragma o c s l1 l2 t m,st) sl) = do
+ exact (HsPragSCC (AnnPragSCC o c l1,st) sl) = do
o' <- markAnnOpen'' o st "{-# SCC"
l1' <- printStringAtAA l1 (sourceTextToString (stringLitSourceText sl) (unpackHText $ sl_fs sl))
c' <- markEpToken c
- return (HsPragSCC (AnnPragma o' c' s l1' l2 t m,st) sl)
+ return (HsPragSCC (AnnPragSCC o' c' l1',st) sl)
instance ExactPrint (HsTypedSplice GhcPs) where
getAnnotationEntry _ = NoEntryVal
@@ -4408,7 +4404,7 @@ instance Typeable p => ExactPrint (CType (GhcPass p)) where
exact (CType ext mh ct) = do
let stp = cTypeSourceText ext
stct = cTypeOtherText ext
- AnnPragma o c s l1 l2 t m = cTypeAnn ext
+ AnnCType o c l1 l2 = cTypeAnn ext
o' <- markAnnOpen'' o stp "{-# CTYPE"
l1' <- case mh of
Nothing -> return l1
@@ -4416,7 +4412,7 @@ instance Typeable p => ExactPrint (CType (GhcPass p)) where
printStringAtAA l1 (toSourceTextWithSuffix srcH "" "")
l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackHText ct) "")
c' <- markEpToken c
- return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct)
+ return (CType (ext { cTypeAnn = AnnCType o' c' l1' l2' }) mh ct)
-- ---------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -838,7 +838,7 @@ type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF
type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA
type instance Anno (CType DocNameI) = SrcSpanAnnA
-type instance Anno (Header DocNameI) = EpAnn AnnPragma
+type instance Anno (Header DocNameI) = SrcSpanAnnA
type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA
type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/528b0d8a5e58b3a5ef84f5e184f89e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/528b0d8a5e58b3a5ef84f5e184f89e…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: hie files: Dump the type table when dumping with -ddump-hie
by Marge Bot (＠marge-bot) 06 Aug '26
by Marge Bot (＠marge-bot) 06 Aug '26
06 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
185df3e6 by Zubin Duggal at 2026-08-06T04:58:20-04:00
hie files: Dump the type table when dumping with -ddump-hie
- - - - -
268b2fe3 by Zubin Duggal at 2026-08-06T04:58:20-04:00
hie files: Take evidence for quantified constraints into account when saving evidence terms to the hie ast
Fixes #25709
- - - - -
8db1de70 by Simon Jakobi at 2026-08-06T04:58:21-04:00
testsuite: fix stale paths for the ghc-config build artifacts
ghc-config.hs moved from testsuite/mk/ to testsuite/ghc-config/ in
6c7a49139c, but the .gitignore entry and the clean rule still referred to
the old location. As a result the compiled ghc-config binary, which
boilerplate.mk rebuilds on every make-driven test run, showed up as an
untracked file and was never cleaned.
Assisted-by: Claude Opus 5
- - - - -
528b0d8a by Simon Peyton Jones at 2026-08-06T04:58:22-04:00
Documentation only
...driven by my investigation of #27591
- - - - -
11 changed files:
- compiler/GHC/Core/Class.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/.gitignore
- testsuite/Makefile
- testsuite/tests/hiefile/should_compile/T24493.stderr
- + testsuite/tests/hiefile/should_run/T25709.hs
- + testsuite/tests/hiefile/should_run/T25709.stdout
- testsuite/tests/hiefile/should_run/all.T
Changes:
=====================================
compiler/GHC/Core/Class.hs
=====================================
@@ -84,9 +84,9 @@ data Class
-- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
type FunDep a = ([a],[a])
-type ClassOpItem = (Id, DefMethInfo)
- -- Selector function; contains unfolding
- -- Default-method info
+type ClassOpItem = ( Id -- Dictionary selector function
+ -- See Note [Dictionary selectors]
+ , DefMethInfo) -- Default-method info
type DefMethInfo = Maybe (Name, DefMethSpec Type)
-- Nothing No default method
@@ -164,7 +164,19 @@ classMinimalDef :: Class -> ClassMinimalDef
classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d
classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction
-{-
+{- Note [Dictionary selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Each `ClassOpItem` stores a dictionary selector `Id`:
+
+* The type of the selector is always closed, and has form
+ forall a1..an. C a1 .. an => blah
+ where `a1..an` are the class variables, and
+ `blah` is the method type.
+ See GHC.Types.Id.Make.mkDictSelId, which constructs them.
+
+* The selector has no unfolding, but one RULE.
+ See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance
+
Note [Associated type defaults]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following is an example of associated type defaults:
=====================================
compiler/GHC/Driver/Main/Passes.hs
=====================================
@@ -92,7 +92,7 @@ import GHC.Iface.Make
import GHC.Iface.Recomp
import GHC.Iface.Tidy
import GHC.Iface.Ext.Ast ( mkHieFile )
-import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
+import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module, hie_types )
import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
@@ -167,7 +167,7 @@ import GHC.Data.StringBuffer
import GHC.Data.Maybe
import qualified GHC.Data.Strict as Strict
-
+import qualified Data.Array as A
import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
import Control.Monad
@@ -332,7 +332,10 @@ extract_renamed_stuff mod_summary tc_result = do
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
let out_file = ml_hie_file $ ms_location mod_summary
liftIO $ writeHieFile out_file hieFile
- liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
+ let hie_doc =
+ ppr (hie_asts hieFile)
+ $+$ ppr (A.assocs $ hie_types hieFile)
+ liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell hie_doc
-- Validate HIE files
when (gopt Opt_ValidateHie dflags) $ do
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -159,6 +159,18 @@ data HieType a
| HCoercionTy
deriving (Functor, Foldable, Traversable, Eq)
+instance Outputable a => Outputable (HieType a) where
+ ppr (HTyVarTy name) = ppr name
+ ppr (HAppTy fun arg) = parens $ ppr fun <+> ppr arg
+ ppr (HTyConApp tc args) = parens $ ppr tc <+> ppr args
+ ppr (HForAllTy ((name, ty), flag) body) =
+ text "forall" <+> ppr flag <+> ppr name O.<> text ":" <+> ppr ty O.<> text "." <+> ppr body
+ ppr (HFunTy mult arg res) = parens $ ppr arg <+> arrow <+> ppr res <+> ppr mult
+ ppr (HQualTy ctxt ty) = parens $ ppr ctxt <+> text "=>" <+> ppr ty
+ ppr (HLitTy lit) = ppr lit
+ ppr (HCastTy ty) = text "cast" <+> ppr ty
+ ppr HCoercionTy = text "<coercion>"
+
type HieTypeFlat = HieType TypeIndex
-- | Roughly isomorphic to the original core 'Type'.
@@ -222,6 +234,10 @@ instance Binary (HieArgs TypeIndex) where
put_ bh (HieArgs xs) = put_ bh xs
get bh = HieArgs <$> get bh
+instance Outputable a => Outputable (HieArgs a) where
+ ppr (HieArgs args) = braces $ hsep $ punctuate comma $ map pprArg args
+ where pprArg (vis, ty) = (if vis then id else parens) (ppr ty)
+
-- A HiePath is just a lexical FastString. We use a lexical FastString to avoid
-- non-determinism when printing or storing HieASTs which are sorted by their
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -1188,10 +1188,20 @@ bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed
-> RnM (a, FreeNames)
bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
case outer_bndrs of
+
HsOuterImplicit{} ->
+ -- Add an implicit `forall a1..an` at the top, where `a1..an`
+ -- are not-otherwise-in-scope type variables.
+ -- Used when there is no forall, or a /visible/ (forall a -> blah)
+ -- See Note [forall-or-nothing rule] in Language.Haskell.Syntax.Type
rnImplicitTvOccs mb_cls implicit_vars $ \implicit_vars' ->
thing_inside $ HsOuterImplicit { hso_ximplicit = implicit_vars' }
+
HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ -- The type already has an explicit, user-written, invisible forall,
+ -- so do not add an implicit forall
+ -- See Note [forall-or-nothing rule] in Language.Haskell.Syntax.Type
+ --
-- Note: If we pass mb_cls instead of Nothing below, bindLHsTyVarBndrs
-- will use class variables for any names the user meant to bring in
-- scope here. This is an explicit forall, so we want fresh names, not
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -480,7 +480,7 @@ Therefore there is no loss of generality if we make all selectors unrestricted.
mkDictSelId :: Name -- Name of one of the *value* selectors
-- (dictionary superclass or method)
-> Class -> Id
--- Important: see Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance
+-- See Note [Dictionary selectors]
mkDictSelId name clas
= mkGlobalId (ClassOpId clas terminating) name sel_ty info
where
=====================================
testsuite/.gitignore
=====================================
@@ -72,7 +72,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
# NOTE: to edit this section in Vim, add your ignore annotations some where
# in the list, select the entire section and say ':sort u' to sort it.
-/mk/ghc-config
+/ghc-config/ghc-config
/tests/ado/ado001
/tests/annotations/should_compile/th/build_make
=====================================
testsuite/Makefile
=====================================
@@ -46,5 +46,6 @@ clean distclean maintainer-clean:
$(RM) -f mk/*.o
$(RM) -f mk/*.hi
$(RM) -f mk/ghcconfig*.mk
- $(RM) -f mk/ghc-config mk/ghc-config.exe
+ $(RM) -f ghc-config/ghc-config ghc-config/ghc-config.exe
+ $(RM) -f ghc-config/ghc-config.o ghc-config/ghc-config.hi
$(RM) -f driver/*.pyc
=====================================
testsuite/tests/hiefile/should_compile/T24493.stderr
=====================================
@@ -1,3 +1,4 @@
+
==================== HIE AST ====================
File: T24493.hs
Node@T24493.hs:(1,8)-(3,8): Source: From source
@@ -25,9 +26,10 @@ Node@T24493.hs:(1,8)-(3,8): Source: From source
Node@T24493.hs:3:6-8: Source: From source
{(annotations: {(HsLit, HsExpr)}), (types: [0]),
(identifier info: {})}
-
+
+[(0, (GHC.Internal.Base.String {}))]
Got valid scopes
-Got no roundtrip errors
\ No newline at end of file
+Got no roundtrip errors
=====================================
testsuite/tests/hiefile/should_run/T25709.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE QuantifiedConstraints#-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Main where
+
+import TestUtils
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import Data.Either
+import Data.Maybe
+import Data.Bifunctor (first)
+import GHC.Plugins (moduleNameString, nameStableString, nameOccName, occNameString, isDerivedOccName)
+import GHC.Iface.Ext.Types
+
+
+import Data.Typeable
+
+data Some c where
+ Some :: c a => a -> Some c
+
+extractSome :: (Typeable a, forall x. c x => Typeable x) => Some c -> Maybe a
+extractSome (Some a) = cast a
+
+f :: (forall x. Ord x => Eq [x]) => ()
+f = ()
+{-# NOINLINE f #-}
+
+g :: ()
+g = f
+
+useQC :: forall c a. (c a, forall x. c x => Show x) => a -> String
+useQC x = show x
+
+points :: [(Int,Int)]
+points = [(22,26),(29, 5), (32, 13)]
+
+main = do
+ (df, hf) <- readTestHie "T25709.hie"
+ let refmap = generateReferencesMap $ getAsts $ hie_asts hf
+ traverse (explainEv df hf refmap) points
=====================================
testsuite/tests/hiefile/should_run/T25709.stdout
=====================================
@@ -0,0 +1,110 @@
+==========================
+At point (22,26), we found:
+==========================
+┌
+│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a
+│ is an evidence variable bound by a let, depending on: [$dTypeable]
+│ with scope: LocalScope T25709.hs:22:14-29
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $dTypeable at T25709.hs:22:1-29, of type: Typeable a
+ │ is an evidence variable bound by a HsWrapper
+ │ with scope: LocalScope T25709.hs:22:1-29
+ │ bound at: T25709.hs:22:1-29
+ │ Defined at <no location info>
+ └
+
+┌
+│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a
+│ is an evidence variable bound by a let, depending on: [df, irred]
+│ with scope: LocalScope T25709.hs:22:14-29
+│
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ df at T25709.hs:22:1-29, of type: forall x. c x => Typeable x
+| │ is an evidence variable bound by a HsWrapper
+| │ with scope: LocalScope T25709.hs:22:1-29
+| │ bound at: T25709.hs:22:1-29
+| │ Defined at <no location info>
+| └
+|
+`- ┌
+ │ irred at T25709.hs:22:14-19, of type: c a
+ │ is an evidence variable bound by a let, depending on: [irred]
+ │ with scope: LocalScope T25709.hs:22:14-29
+ │
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ irred at T25709.hs:22:14-19, of type: c a
+ │ is an evidence variable bound by a pattern
+ │ with scope: LocalScope T25709.hs:22:14-29
+ │
+ │ Defined at <no location info>
+ └
+
+==========================
+At point (29,5), we found:
+==========================
+┌
+│ df at T25709.hs:1:1, of type: forall x. Ord x => Eq [x]
+│ is an evidence variable bound by a let, depending on: [$p1Ord,
+│ $fEqList]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ $p1Ord at T25709.hs:1:1, of type: forall a. Ord a => Eq a
+| │ is a usage of an external evidence variable
+| │ Defined in `GHC.Internal.Classes'
+| └
+|
+`- ┌
+ │ $fEqList at T25709.hs:1:1, of type: forall a. Eq a => Eq [a]
+ │ is a usage of an external evidence variable
+ │ Defined in `GHC.Internal.Classes'
+ └
+
+==========================
+At point (32,13), we found:
+==========================
+┌
+│ $dShow at T25709.hs:32:1-16, of type: Show a
+│ is an evidence variable bound by a let, depending on: [df, irred]
+│ with scope: LocalScope T25709.hs:32:1-16
+│ bound at: T25709.hs:32:1-16
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ df at T25709.hs:32:1-16, of type: forall x. c x => Show x
+| │ is an evidence variable bound by a HsWrapper
+| │ with scope: LocalScope T25709.hs:32:1-16
+| │ bound at: T25709.hs:32:1-16
+| │ Defined at <no location info>
+| └
+|
+`- ┌
+ │ irred at T25709.hs:32:1-16, of type: c a
+ │ is an evidence variable bound by a let, depending on: [irred]
+ │ with scope: LocalScope T25709.hs:32:1-16
+ │ bound at: T25709.hs:32:1-16
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ irred at T25709.hs:32:1-16, of type: c a
+ │ is an evidence variable bound by a HsWrapper
+ │ with scope: LocalScope T25709.hs:32:1-16
+ │ bound at: T25709.hs:32:1-16
+ │ Defined at <no location info>
+ └
+
=====================================
testsuite/tests/hiefile/should_run/all.T
=====================================
@@ -8,4 +8,5 @@ test('HieVdq', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUti
test('T23540', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('T23120', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('T24544', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
-test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
\ No newline at end of file
+test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('T25709', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/363d13e0bcc526a8b7bfaccf52bf99…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/363d13e0bcc526a8b7bfaccf52bf99…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/sjakobi/udfm-placement] Use a pigeonhole sort for deterministic UniqDFM iteration
by Simon Jakobi (＠sjakobi) 06 Aug '26
by Simon Jakobi (＠sjakobi) 06 Aug '26
06 Aug '26
Simon Jakobi pushed to branch wip/sjakobi/udfm-placement at Glasgow Haskell Compiler / GHC
Commits:
2b96b592 by Simon Jakobi at 2026-08-06T09:38:09+02:00
Use a pigeonhole sort for deterministic UniqDFM iteration
Deterministic UniqDFM iteration used a list mergesort, allocating O(n
log n) cons cells and contributing significantly to compiler allocations
(#27459).
Use a pigeonhole sort where appropriate, while retaining the mergesort
fallback. See Note [Sorting a UDFM] and Note [Cost of deterministic
iteration].
-------------------------
Metric Decrease:
InstanceMatching
InstanceMatching1
ManyAlternatives
T12707
T13379
T13719
T24471
T27336
T5321FD
T5321Fun
T783
-------------------------
Assisted-by: gpt-5.6-sol via Codex CLI
- - - - -
5 changed files:
- 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/Types/Unique/DFM.hs
Changes:
=====================================
compiler/GHC/Data/Word64Map/Internal.hs
=====================================
@@ -170,6 +170,7 @@ module GHC.Data.Word64Map.Internal (
, map
, mapWithKey
, traverseWithKey
+ , traverseWithKey_
, traverseMaybeWithKey
, mapAccum
, mapAccumWithKey
@@ -2520,6 +2521,16 @@ traverseWithKey f = go
| otherwise = liftA2 (Bin p m) (go l) (go r)
{-# INLINE traverseWithKey #-}
+-- | \(O(n)\). Visit each key\/value pair in ascending key order, discarding
+-- the results.
+traverseWithKey_ :: Applicative t => (Key -> a -> t ()) -> Word64Map a -> t ()
+traverseWithKey_ f = go
+ where
+ go Nil = pure ()
+ go (Tip k v) = f k v
+ go (Bin _ _ l r) = go l *> go r
+{-# INLINE traverseWithKey_ #-}
+
-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating
-- argument through the map in ascending order of keys.
--
=====================================
compiler/GHC/Data/Word64Map/Lazy.hs
=====================================
@@ -149,6 +149,7 @@ module GHC.Data.Word64Map.Lazy (
, WM.map
, mapWithKey
, traverseWithKey
+ , traverseWithKey_
, traverseMaybeWithKey
, mapAccum
, mapAccumWithKey
=====================================
compiler/GHC/Data/Word64Map/Strict.hs
=====================================
@@ -166,6 +166,7 @@ module GHC.Data.Word64Map.Strict (
, map
, mapWithKey
, traverseWithKey
+ , traverseWithKey_
, traverseMaybeWithKey
, mapAccum
, mapAccumWithKey
=====================================
compiler/GHC/Data/Word64Map/Strict/Internal.hs
=====================================
@@ -168,6 +168,7 @@ module GHC.Data.Word64Map.Strict.Internal (
, map
, mapWithKey
, traverseWithKey
+ , traverseWithKey_
, traverseMaybeWithKey
, mapAccum
, mapAccumWithKey
@@ -330,6 +331,7 @@ import GHC.Data.Word64Map.Internal
, toAscList
, toDescList
, toList
+ , traverseWithKey_
, union
, unions
, withoutKeys
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -14,6 +14,9 @@ See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ o
is not deterministic.
-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
{-# OPTIONS_GHC -Wall #-}
module GHC.Types.Unique.DFM (
@@ -79,6 +82,9 @@ import Data.Functor.Classes (Eq1 (..))
import Data.List (sortBy)
import Data.Function (on)
import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM)
+import GHC.Data.SmallArray
+import GHC.Exts (State#, build)
+import GHC.ST (ST(..), runST)
import Unsafe.Coerce
import qualified GHC.Data.Word64Set as W
@@ -96,10 +102,10 @@ import qualified GHC.Data.Word64Set as W
-- This means `alterUDFM` consistent with `addToUDFM` and `adjustUDFM`,
-- so that for example `alterUDFM id k = id` and `alterUDFM (fmap f) k = adjustUDFM f k`
--
--- There is an implementation cost: each element is given a serial number
--- as it is added, and `udfmToList` sorts its result by this serial
--- number. So you should only use `UniqDFM` if you need the deterministic
--- property.
+-- There is an implementation cost: each element is given an insertion tag
+-- as it is added, and functions like `udfmToList` or `eltsUDFM` order their
+-- results by this tag (see Note [Cost of deterministic iteration]). So you
+-- should only use `UniqDFM` if you need the deterministic property.
--
-- `foldUDFM` also preserves determinism.
--
@@ -112,7 +118,7 @@ import qualified GHC.Data.Word64Set as W
--
--
-- There's more than one way to implement this. The implementation here tags
--- every value with the insertion time that can later be used to sort the
+-- every value with its insertion tag that can later be used to sort the
-- values when asked to convert to a list.
--
-- Updating an existing key keeps the old tag. This keeps the order stable for
@@ -125,7 +131,7 @@ import qualified GHC.Data.Word64Set as W
--
-- An alternative would be to have
--
--- data UniqDFM ele = UDFM (M.IntMap ele) [ele]
+-- data UniqDFM ele = UDFM (Word64Map ele) [ele]
--
-- where the list determines the order. This makes deletion tricky as we'd
-- only accumulate elements in that list, but makes merging easier as you
@@ -133,11 +139,11 @@ import qualified GHC.Data.Word64Set as W
-- Deletion can probably be done in amortized fashion when the size of the
-- list is twice the size of the set.
--- | A type of values tagged with insertion time
+-- | A type of values carrying an insertion tag
data TaggedVal val =
TaggedVal
!val
- {-# UNPACK #-} !Int -- ^ insertion time
+ {-# UNPACK #-} !Int -- ^ insertion tag
deriving stock (Data, Functor, Foldable, Traversable)
taggedFst :: TaggedVal val -> val
@@ -159,18 +165,30 @@ instance Eq val => Eq (TaggedVal val) where
data UniqDFM key ele =
UDFM
!(M.Word64Map (TaggedVal ele)) -- A map where keys are Unique's values and
- -- values are tagged with insertion time.
- -- The invariant is that all the tags will
- -- be distinct within a single map
- {-# UNPACK #-} !Int -- Upper bound on the values' insertion
- -- time. See Note [Overflow on plusUDFM]
+ -- values carry an insertion tag.
+ {-# UNPACK #-} !Int -- Upper bound on the values' insertion
+ -- tags. See Note [Overflow on plusUDFM]
+ -- See Note [UDFM invariants]
deriving (Data, Functor)
--- | Deterministic, in O(n log n).
+{- Note [UDFM invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+In a map (UDFM m ub):
+
+ (a) The insertion tags of the elements of m are distinct.
+ (b) Every tag lies in [0, ub).
+
+Consequently ub >= size m.
+
+The tags determine the order of deterministic iteration (eltsUDFM,
+udfmToList). See Note [Sorting a UDFM].
+-}
+
+-- | Deterministic. See Note [Cost of deterministic iteration].
instance Foldable (UniqDFM key) where
foldr = foldUDFM
--- | Deterministic, in O(n log n).
+-- | Deterministic. See Note [Cost of deterministic iteration].
instance Traversable (UniqDFM key) where
traverse f = fmap listToUDFM_Directly
. traverse (\(u,a) -> (u,) <$> f a)
@@ -264,8 +282,8 @@ plusUDFM_CK f udfml@(UDFM _ i) udfmr@(UDFM _ j)
-- Note [Overflow on plusUDFM]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- There are multiple ways of implementing plusUDFM.
--- The main problem that needs to be solved is overlap on times of
--- insertion between different keys in two maps.
+-- The main problem that needs to be solved is overlap on insertion
+-- tags between different keys in two maps.
-- Consider:
--
-- A = fromList [(a, (x, 1))]
@@ -325,13 +343,27 @@ elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool
elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m
-- | Performs a deterministic fold over the UniqDFM.
--- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
+--
+-- O(n) in the common case, with an O(n log n) fallback.
+--
+-- See Note [Cost of deterministic iteration].
foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a
{-# INLINE foldUDFM #-}
--- This INLINE prevents a regression in !10568
-foldUDFM k z m = foldr k z (eltsUDFM m)
-
--- | Like 'foldUDFM' but the function also receives a key
+-- Specialises k and z into M.foldr on the small-map path.
+foldUDFM k z (UDFM m ub)
+ | M.compareSize m 1 /= GT = M.foldr (k . taggedFst) z m
+ | otherwise = fold_udfm k z m ub
+
+fold_udfm :: (elt -> a -> a) -> a -> M.Word64Map (TaggedVal elt) -> Int -> a
+{-# NOINLINE fold_udfm #-}
+-- Kept out of line so that foldUDFM's consumers don't inline the sort machinery.
+fold_udfm k z m ub
+ | usePigeonholeSort m ub = foldr k z (pigeonholeSort ub (\_ tv -> tv) m)
+ | otherwise = foldr k z (map taggedFst (sort_it m))
+
+-- | Like 'foldUDFM' but the function also receives a key.
+--
+-- See Note [Cost of deterministic iteration].
foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a
{-# INLINE foldWithKeyUDFM #-}
-- This INLINE was copied from foldUDFM
@@ -346,14 +378,113 @@ nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m
where
k' acc (TaggedVal v _) = k v acc
+{- Note [Cost of deterministic iteration]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deterministic iteration -- foldUDFM, eltsUDFM, udfmToList, and everything
+built on them -- orders elements by insertion tag. The element with the
+smallest tag can sit anywhere in the map, so every tag must be inspected,
+and, given a @UDFM m ub@ on the pigeonhole-sort path, an array with ub slots
+must be filled, before the first element can be emitted (see
+Note [Sorting a UDFM]). So beyond maps of a single element, deterministic
+iteration cannot stream: demanding any of the result processes the whole
+map. #27459 shows that cost hitting a consumer that only needed to know
+whether the result was non-empty.
+
+So: to test for emptiness, use isNullUDFM rather than null on eltsUDFM;
+for order-oblivious queries, prefer short-circuiting anyUDFM/allUDFM; and
+if you don't need the deterministic order at all, use nonDetStrictFoldUDFM.
+-}
+
+-- | Deterministic, in order of insertion.
+--
+-- See Note [Sorting a UDFM] and Note [Cost of deterministic iteration].
eltsUDFM :: UniqDFM key elt -> [elt]
-{-# INLINE eltsUDFM #-}
--- The INLINE makes it a good producer (from the map)
-eltsUDFM (UDFM m _i) = map taggedFst (sort_it m)
+{-# INLINE eltsUDFM #-} -- so the small case is a good producer
+ -- This matters for T13719.
+eltsUDFM (UDFM m ub)
+ | M.compareSize m 1 /= GT = build (\c n -> M.foldr (c . taggedFst) n m)
+ | otherwise = elts_udfm m ub
+
+elts_udfm :: M.Word64Map (TaggedVal elt) -> Int -> [elt]
+{-# NOINLINE elts_udfm #-}
+-- Kept out of line so that eltsUDFM's consumers don't inline the sort machinery.
+elts_udfm m ub
+ | usePigeonholeSort m ub = pigeonholeSort ub (\_ tv -> tv) m
+ | otherwise = map taggedFst (sort_it m)
sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt]
sort_it m = sortBy (compare `on` taggedSnd) (M.elems m)
+
+{- Note [Sorting a UDFM]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Deterministic iteration must yield a map's elements in order of their
+insertion tags. The obvious way is to sort on the tags, but we can do better:
+in (UDFM m ub) the tags are distinct indices into [0, ub) (see
+Note [UDFM invariants]), so each element can simply be placed at its own
+tag in an ub-slot array, which is then read back in index order. This is
+pigeonhole sort, with one element per hole.
+
+Cost: writing the elements is O(n) for n = M.size m, while allocating the
+array and reading it back are O(ub). Since n <= ub the total is O(ub). No
+comparisons are made.
+
+So the method wins only while the array stays dense, and ub never shrinks
+(overwrites keep bumping it, delete/filter shrink n but not ub).
+usePigeonholeSort therefore takes this path only when ub <= 4 * n, which
+bounds its cost at O(n), and falls back to the O(n log n) comparison sort
+otherwise.
+
+Unfilled slots contain a TaggedVal with tag -1 and value
+@unsafeCoerce () :: r@. This is safe because the value is never used: only
+slots with non-negative tags are read.
+
+pigeonholeSort also avoids intermediate lists: it fills the array by
+traversing the map directly, and emits its readout with 'build', so the foldr
+in fold_udfm fuses with it. This contributes significantly to the allocation
+reductions in InstanceMatching1 in !16292.
+-}
+
+-- | @ub <= 4 * size m@, computed without a full 'M.size' traversal.
+usePigeonholeSort :: M.Word64Map a -> Int -> Bool
+usePigeonholeSort m ub = M.compareSize m ceil_ub_div_4 /= LT
+ where
+ ceil_ub_div_4 = (ub + 3) `div` 4 -- ceil(ub/4): ub <= 4*n iff n >= ceil(ub/4)
+
+-- | Order the map's elements by tag. The tags must be distinct and in
+-- @[0, ub)@, and @mk@ must preserve them. See Note [Sorting a UDFM].
+pigeonholeSort :: forall e r. Int
+ -> (M.Key -> TaggedVal e -> TaggedVal r)
+ -> M.Word64Map (TaggedVal e)
+ -> [r]
+{-# INLINE pigeonholeSort #-} -- Specialise mk and enable foldr/build fusion.
+pigeonholeSort ub mk m = build gen
+ where
+ -- The tag -1 marks unfilled slots; the value field is never read, but it
+ -- is strict, so it needs a WHNF value of type r. See Note [Sorting a UDFM].
+ hole :: TaggedVal r
+ hole = TaggedVal (unsafeCoerce ()) (-1)
+
+ fill :: SmallMutableArray s (TaggedVal r) -> State# s -> (# State# s, () #)
+ fill marr s = case M.traverseWithKey_ write m of ST st -> st s
+ where
+ write k tv = ST (\s' ->
+ (# writeSmallArray marr (taggedSnd tv) (mk k tv) s', () #))
+
+ gen :: forall b. (r -> b -> b) -> b -> b
+ gen cons nil = runST (ST (\s0 ->
+ case newSmallArray ub hole s0 of
+ (# s1, marr #) -> case fill marr s1 of
+ (# s2, () #) -> case unsafeFreezeSmallArray marr s2 of
+ (# s3, arr #) -> (# s3, readout arr 0 #)))
+ where
+ readout :: SmallArray (TaggedVal r) -> Int -> b
+ readout arr j
+ | j >= ub = nil
+ | t < 0 = readout arr (j + 1)
+ | otherwise = cons v (readout arr (j + 1))
+ where TaggedVal v t = indexSmallArray arr j
+
filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt
filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i
@@ -371,11 +502,22 @@ udfmRestrictKeysSet (UDFM val_set i) set =
in UDFM (M.restrictKeys val_set key_set) i
-- | Converts `UniqDFM` to a list, with elements in deterministic order.
--- It's O(n log n) while the corresponding function on `UniqFM` is O(n).
+--
+-- O(n) in the common case, with an O(n log n) fallback.
+--
+-- See Note [Cost of deterministic iteration].
udfmToList :: UniqDFM key elt -> [(Unique, elt)]
-udfmToList (UDFM m _i) =
- [ (mkUniqueGrimily k, taggedFst v)
- | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
+-- NB: no INLINE, unlike eltsUDFM. udfmToList's one hot consumer is
+-- traverseUSDFM in the pattern-match checker, which doesn't fuse. Inlining
+-- the size dispatch into it regresses T17836.
+udfmToList (UDFM m ub)
+ | M.compareSize m 1 /= GT =
+ M.foldrWithKey (\k tv r -> (mkUniqueGrimily k, taggedFst tv) : r) [] m
+ | usePigeonholeSort m ub = pigeonholeSort ub
+ (\k tv -> TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv)) m
+ | otherwise =
+ [ (mkUniqueGrimily k, taggedFst v)
+ | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
-- Determines whether two 'UniqDFM's contain the same keys.
equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b96b592906f14df41a8eb358c5d8d3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b96b592906f14df41a8eb358c5d8d3…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0