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/7718b39f1883b4a66176889b37379fd7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7718b39f1883b4a66176889b37379fd7... 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