Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC Commits: 4199d6a6 by fendor at 2026-04-10T15:14:33+02:00 WIP: always have a home unit - - - - - f5888de7 by fendor at 2026-04-10T15:14:33+02:00 Use proper initialisation instead of hardcoding the unit - - - - - 18 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Iface/Errors.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Home.hs - compiler/GHC/Unit/Home/Graph.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -677,7 +677,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do { homeUnitEnv_units = unit_state , homeUnitEnv_unit_dbs = Just dbs , homeUnitEnv_dflags = updated_dflags - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env) @@ -768,7 +768,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , homeUnitEnv_unit_dbs = Just dbs , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = old_hpt - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph @@ -892,7 +892,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , homeUnitEnv_unit_dbs = Just dbs , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = old_hpt - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } -- When changing the DynFlags, we want the changes to apply to future @@ -1691,7 +1691,7 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name pkgqual case res of - Found loc m | notHomeModuleMaybe mhome_unit m -> return m + Found loc m | notHomeModule mhome_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -459,7 +459,7 @@ addUnit u = do , ue_home_unit_graph = HUG.unitEnv_singleton (homeUnitId home_unit) - (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) + (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (home_unit)) , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -117,7 +117,7 @@ runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) hsc_home_unit :: HscEnv -> HomeUnit hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env -hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit +hsc_home_unit_maybe :: HscEnv -> HomeUnit hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState @@ -374,7 +374,7 @@ lookupIfaceByModuleHsc hsc_env mod = do lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod mainModIs :: HomeUnitEnv -> Module -mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) +mainModIs hue = mkHomeModule (homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) -- | Retrieve the target code interpreter -- ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -38,6 +38,7 @@ module GHC.Driver.Main newHscEnv , newHscEnvWithHUG , initHscEnv + , createHomeUnitEnvFromFlags -- * Compiling complete source files , Messager, batchMsg, batchMultiMsg @@ -298,6 +299,7 @@ import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable import qualified GHC.ByteCode.Serialize as ByteCode +import qualified Data.Set as Set {- ********************************************************************** %* * @@ -307,18 +309,15 @@ import qualified GHC.ByteCode.Serialize as ByteCode newHscEnv :: FilePath -> DynFlags -> IO HscEnv newHscEnv top_dir dflags = do - hpt <- emptyHomePackageTable - newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt) - where - home_unit_graph hpt = HUG.unitEnv_singleton - (homeUnitId_ dflags) - (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing) + logger <- initLogger + -- TODO: doesn't quite work, we call 'initUnits' in 'createHomeUnitEnvFromFlags' + (home_unit_graph, mainUnitId) <- createHomeUnitEnvFromFlags logger (NE.singleton dflags) + newHscEnvWithHUG logger top_dir dflags mainUnitId home_unit_graph -newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv -newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do +newHscEnvWithHUG :: Logger -> FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv +newHscEnvWithHUG logger top_dir top_dynflags cur_unit home_unit_graph = do nc_var <- newNameCache fc_var <- initFinderCache - logger <- initLogger tmpfs <- initTmpFs let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup cur_unit home_unit_graph unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) @@ -338,6 +337,24 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do , hsc_llvm_config = llvm_config } +createHomeUnitEnvFromFlags :: Logger -> NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) +createHomeUnitEnvFromFlags logger unitDflags = do + let home_units = Set.fromList (NE.toList $ NE.map homeUnitId_ unitDflags) + + homeUnitEnvs <- forM (NE.toList unitDflags) $ \dflags -> do + let cached_unit_dbs = Nothing + hue_flags = dflags + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger hue_flags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + hpt <- liftIO emptyHomePackageTable + pure (homeUnitId home_unit, HUG.mkHomeUnitEnv unit_state (Just dbs) updated_dflags hpt home_unit) + + let activeUnit = homeUnitId_ $ NE.head unitDflags + let home_unit_graph = HUG.hugFromList homeUnitEnvs + return (home_unit_graph, activeUnit) + -- | Initialize HscEnv from an optional top_dir path initHscEnv :: Maybe FilePath -> IO HscEnv initHscEnv mb_top_dir = do ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -473,7 +473,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (case home_unit of - Just hu + hu | isHomeUnitId hu ghcInternalUnitId , platformOS platform == OSMinGW32 -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"] ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -17,10 +17,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Unit.Env import GHC.Unit (UnitId) -import GHC.Unit.Home.PackageTable import qualified GHC.Unit.Home.Graph as HUG -import GHC.Unit.State ( emptyUnitState ) -import qualified GHC.Unit.State as State import GHC.Types.SrcLoc import GHC.Types.SourceError @@ -42,6 +39,7 @@ import GHC.ResponseFile (expandResponse) import Data.Bifunctor import GHC.Data.Graph.Directed import qualified Data.List.NonEmpty as NE +import GHC.Driver.Main (createHomeUnitEnvFromFlags) -- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. removeRTS :: [String] -> [String] @@ -125,24 +123,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags)) - (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags - let home_units = HUG.allUnits initial_home_graph - - home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do - let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv - hue_flags = homeUnitEnv_dflags homeUnitEnv - dflags = homeUnitEnv_dflags homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units - - updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants - emptyHpt <- liftIO $ emptyHomePackageTable - pure $ HomeUnitEnv - { homeUnitEnv_units = unit_state - , homeUnitEnv_unit_dbs = Just dbs - , homeUnitEnv_dflags = updated_dflags - , homeUnitEnv_hpt = emptyHpt - , homeUnitEnv_home_unit = Just home_unit - } + (home_unit_graph, mainUnitId) <- liftIO $ createHomeUnitEnvFromFlags logger unitDflags checkUnitCycles initial_dflags home_unit_graph @@ -232,16 +213,3 @@ offsetDynFlags dflags = augment_maybe (Just f) = Just (augment f) augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f | otherwise = f - - -createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) -createUnitEnvFromFlags unitDflags = do - unitEnvList <- forM unitDflags $ \dflags -> do - emptyHpt <- emptyHomePackageTable - let newInternalUnitEnv = - HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing - return (homeUnitId_ dflags, newInternalUnitEnv) - let activeUnit = fst $ NE.head unitEnvList - return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) - - ===================================== compiler/GHC/Iface/Errors.hs ===================================== @@ -27,7 +27,7 @@ badIfaceFile file err = vcat [text "Bad interface file:" <+> text file, nest 4 err] -cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile +cannotFindInterface :: UnitState -> HomeUnit -> Profile -> ModuleName -> InstalledFindResult -> MissingInterfaceError cannotFindInterface us mhu p mn ifr = CantFindErr us FindingInterface $ @@ -35,7 +35,7 @@ cannotFindInterface us mhu p mn ifr = cantFindInstalledErr :: UnitState - -> Maybe HomeUnit + -> HomeUnit -> Profile -> ModuleName -> InstalledFindResult @@ -52,7 +52,7 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result InstalledNotFound files mb_pkg | Just pkg <- mb_pkg - , notHomeUnitId mhome_unit pkg + , not (isHomeUnitId mhome_unit pkg) -> not_found_in_package pkg $ fmap unsafeDecodeUtf files | null files @@ -111,11 +111,7 @@ cantFindErr unit_env profile mod_name find_result , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest } | Just pkg <- mb_pkg - , Nothing <- mhome_unit -- no home-unit - -> not_found_in_package (toUnitId pkg) files - - | Just pkg <- mb_pkg - , Just home_unit <- mhome_unit -- there is a home-unit but the + , home_unit <- mhome_unit -- there is a home-unit but the , not (isHomeUnit home_unit pkg) -- module isn't from it -> not_found_in_package (toUnitId pkg) files ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -711,12 +711,12 @@ dontLeakTheHUG thing_inside = do -- | Returns @True@ if a 'ModIface' comes from an external package. -- In this case, we should NOT load it into the EPS; the entities -- should instead come from the local merged signature interface. -is_external_sig :: Maybe HomeUnit -> ModIface -> Bool +is_external_sig :: HomeUnit -> ModIface -> Bool is_external_sig mhome_unit iface = -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package - notHomeModuleMaybe mhome_unit (mi_module iface) + notHomeModule mhome_unit (mi_module iface) -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only @@ -745,7 +745,7 @@ computeInterface hsc_env doc_str hi_boot_file mod0 = do m mod0 hi_boot_file case getModuleInstantiation mod0 of (imod, Just indef) - | Just home_unit <- mhome_unit + | home_unit <- mhome_unit , isHomeUnitIndefinite home_unit -> find_iface imod >>= \case Succeeded (iface0, path) -> @@ -803,13 +803,13 @@ moduleFreeHolesPrecise doc_str mod return (Succeeded (renameFreeHoles ifhs insts)) Failed err -> return (Failed err) -wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom +wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr MissingInterfaceError IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot wantHiBootFile mhome_unit eps mod from = case from of ImportByUser usr_boot - | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod + | usr_boot == IsBoot && notHomeModule mhome_unit mod -> Failed (BadSourceImport mod) | otherwise -> Succeeded usr_boot @@ -817,7 +817,7 @@ wantHiBootFile mhome_unit eps mod from -> Succeeded NotBoot ImportBySystem - | notHomeModuleMaybe mhome_unit mod + | notHomeModule mhome_unit mod -> Succeeded NotBoot -- If the module to be imported is not from this package -- don't look it up in eps_is_boot, because that is keyed ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -163,8 +163,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... case ue_homeUnit unit_env of - Nothing -> no_obj mod - Just home_unit -> do + home_unit -> do let fc = ldFinderCache opts let fopts = ldFinderOpts opts ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -452,7 +452,7 @@ renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual renamePkgQual unit_env mn mb_pkg = case mb_pkg of Nothing -> NoPkgQual Just pkg_fs - | Just uid <- homeUnitId <$> ue_homeUnit unit_env + | uid <- homeUnitId (ue_homeUnit unit_env) , pkg_fs == fsLit "this" -> ThisPkg uid ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -489,8 +489,7 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... case ue_homeUnit unit_env of - Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod) - Just home_unit -> do + home_unit -> do mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) case mb_stuff of Found loc mod -> found loc mod ===================================== compiler/GHC/Tc/Utils/Backpack.hs ===================================== @@ -285,7 +285,7 @@ implicitRequirements hsc_env normal_imports forM normal_imports $ \(mb_pkg, L _ imp) -> do found <- findImportedModule hsc_env imp mb_pkg case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule mhome_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where @@ -307,7 +307,7 @@ implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports go (accL, accR) ((_stage, mb_pkg, L _ imp):imports) = do found <- findImportedModule hsc_env imp mb_pkg let acc' = case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule mhome_unit mod -> case moduleUnit mod of HoleUnit -> (moduleName mod : accL, accR) RealUnit _ -> (accL, accR) ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -2406,7 +2406,7 @@ initIfaceTcRn thing_inside !knot_vars = tcg_type_env_var tcg_env -- When we are instantiating a signature, we DEFINITELY -- do not want to knot tie. - is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit) + is_instantiate = (isHomeUnitInstantiating mhome_unit) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", if_rec_types = ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -214,14 +214,13 @@ preloadUnitsInfo' unit_env ids0 = all_infos where unit_state = HUG.homeUnitEnv_units (ue_currentHomeUnitEnv unit_env) ids = ids0 ++ inst_ids - inst_ids = case ue_homeUnit unit_env of - Nothing -> [] - Just home_unit - -- An indefinite package will have insts to HOLE, + home_unit = ue_homeUnit unit_env + inst_ids + -- An indefinite package will have insts to HOLE, -- which is not a real package. Don't look it up. -- Fixes #14525 - | isHomeUnitIndefinite home_unit -> [] - | otherwise -> map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) + | isHomeUnitIndefinite home_unit = [] + | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) pkg_map = unitInfoMap unit_state preload = preloadUnits unit_state @@ -302,20 +301,18 @@ ue_setFlags dflags env = -- Query and modify home units in HomeUnitEnv -- ------------------------------------------------------- -ue_homeUnit :: UnitEnv -> Maybe HomeUnit +ue_homeUnit :: UnitEnv -> HomeUnit ue_homeUnit = HUG.homeUnitEnv_home_unit . ue_currentHomeUnitEnv ue_unsafeHomeUnit :: UnitEnv -> HomeUnit -ue_unsafeHomeUnit ue = case ue_homeUnit ue of - Nothing -> panic "ue_unsafeHomeUnit: No home unit" - Just h -> h +ue_unsafeHomeUnit ue = ue_homeUnit ue ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit ue_unitHomeUnit_maybe uid ue_env = - HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) + HUG.homeUnitEnv_home_unit <$> HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) -- ------------------------------------------------------- -- Query and modify the currently active unit ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -195,33 +195,29 @@ findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv - -> Maybe HomeUnit + -> HomeUnit -> ModuleName -> PkgQual -> IO FindResult findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import - ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import + ThisPkg uid | (homeUnitId mhome_unit) == uid -> home_import | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) - | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where - all_opts = case mhome_unit of - Nothing -> other_fopts - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + all_opts = (homeUnitId mhome_unit, fopts) : other_fopts - home_import = case mhome_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit") + home_import = findHomeModule fc fopts mhome_unit mod_name home_pkg_import (uid, opts) -- If the module is reexported, then look for it as if it was from the perspective -- of that package which reexports it. | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue (DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual | elementOfUniqSet mod_name (finder_hiddenModules opts) = return (mkHomeHidden uid) | otherwise = @@ -238,9 +234,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = `orIfNotFound` findExposedPackageModule fc fopts units mod_name NoPkgQual - units = case mhome_unit of - Nothing -> ue_homeUnitState ue - Just home_unit -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue + units = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId mhome_unit) ue hpt_deps :: [UnitId] hpt_deps = Set.toList (homeUnitDepends units) other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps @@ -249,13 +243,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified. -findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModuleNoHsc fc fopts units (Just home_unit) mod_name = +findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> ModuleName -> IO FindResult +findPluginModuleNoHsc fc fopts units home_unit mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` findExposedPluginPackageModule fc fopts units mod_name -findPluginModuleNoHsc fc fopts units Nothing mod_name = - findExposedPluginPackageModule fc fopts units mod_name findPluginModule :: HscEnv -> ModuleName -> IO FindResult findPluginModule hsc_env mod_name = do @@ -267,15 +259,15 @@ findPluginModule hsc_env mod_name = do -- | A version of findExactModule which takes the exact parts of the HscEnv it needs -- directly. -findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do res <- case mhome_unit of - Just home_unit + home_unit | isHomeInstalledModule home_unit mod -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod) | Just home_fopts <- HUG.unitEnv_lookup_maybe (moduleUnit mod) other_fopts -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod) - _ -> findPackageModule fc unit_state fopts mod + | otherwise -> findPackageModule fc unit_state fopts mod case (res, is_boot) of (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc)) _ -> return res ===================================== compiler/GHC/Unit/Home.hs ===================================== @@ -211,9 +211,8 @@ homeModuleNameInstantiation hu mod_name = -- the instantiating module of @r:A@ in @p[A=q[]:B]@ is @r:A@. -- the instantiating module of @p:A@ in @p@ is @p:A@. -- the instantiating module of @r:A@ in @p@ is @r:A@. -homeModuleInstantiation :: Maybe HomeUnit -> Module -> Module -homeModuleInstantiation mhu mod - | Just hu <- mhu - , isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod) +homeModuleInstantiation :: HomeUnit -> Module -> Module +homeModuleInstantiation hu mod + | isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod) | otherwise = mod ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -160,11 +160,11 @@ data HomeUnitEnv = HomeUnitEnv -- -- (This changes a previous invariant: changed Jan 05.) - , homeUnitEnv_home_unit :: !(Maybe HomeUnit) + , homeUnitEnv_home_unit :: !(HomeUnit) -- ^ Home-unit } -mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv +mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> HomeUnit -> HomeUnitEnv mkHomeUnitEnv us dbs dflags hpt home_unit = HomeUnitEnv { homeUnitEnv_units = us , homeUnitEnv_unit_dbs = dbs @@ -383,6 +383,6 @@ pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> IO SDoc pprHomeUnitEnv uid env = do hptDoc <- pprHPT $ homeUnitEnv_hpt env return $ - ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" + ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr ( homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" $$ nest 4 hptDoc ===================================== ghc/GHCi/UI.hs ===================================== @@ -737,7 +737,7 @@ installInteractiveHomeUnits = do [ sessionUnitExposedFlag ] ++ [ homeUnitPkgFlag uid | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env - , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv] + , let homeUnit = homeUnitEnv_home_unit homeUnitEnv , let uid = homeUnitId homeUnit ] ++ (packageFlags dflags0) @@ -753,7 +753,7 @@ installInteractiveHomeUnits = do { packageFlags = [ homeUnitPkgFlag uid | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env - , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv] + , let homeUnit = homeUnitEnv_home_unit homeUnitEnv , let uid = homeUnitId homeUnit ] ++ (packageFlags dflags) @@ -801,7 +801,7 @@ installInteractiveHomeUnits = do (dbs,unit_state,home_unit,_mconstants) <- liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units hpt <- liftIO emptyHomePackageTable - pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit)) + pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt home_unit) reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13c8c0d1897458653227a8391a8aad8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13c8c0d1897458653227a8391a8aad8... You're receiving this email because of your account on gitlab.haskell.org.