Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC
Commits:
-
400ee8a1
by fendor at 2026-08-26T15:49:16+02:00
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:
| ... | ... | @@ -678,7 +678,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do |
| 678 | 678 | hue
|
| 679 | 679 | { homeUnitEnv_units = unit_state
|
| 680 | 680 | , homeUnitEnv_dflags = updated_dflags
|
| 681 | - , homeUnitEnv_home_unit = Just home_unit
|
|
| 681 | + , homeUnitEnv_home_unit = home_unit
|
|
| 682 | 682 | }
|
| 683 | 683 | |
| 684 | 684 | let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)
|
| ... | ... | @@ -767,7 +767,7 @@ setProgramDynFlags_ invalidate_needed dflags = do |
| 767 | 767 | { homeUnitEnv_units = unit_state
|
| 768 | 768 | , homeUnitEnv_dflags = updated_dflags
|
| 769 | 769 | , homeUnitEnv_hpt = old_hpt
|
| 770 | - , homeUnitEnv_home_unit = Just home_unit
|
|
| 770 | + , homeUnitEnv_home_unit = home_unit
|
|
| 771 | 771 | }
|
| 772 | 772 | |
| 773 | 773 | 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 |
| 891 | 891 | { homeUnitEnv_units = unit_state
|
| 892 | 892 | , homeUnitEnv_dflags = updated_dflags
|
| 893 | 893 | , homeUnitEnv_hpt = old_hpt
|
| 894 | - , homeUnitEnv_home_unit = Just home_unit
|
|
| 894 | + , homeUnitEnv_home_unit = home_unit
|
|
| 895 | 895 | }
|
| 896 | 896 | |
| 897 | 897 | -- When changing the DynFlags, we want the changes to apply to future
|
| ... | ... | @@ -1684,7 +1684,7 @@ findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module |
| 1684 | 1684 | findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
|
| 1685 | 1685 | let logger = hsc_logger hsc_env
|
| 1686 | 1686 | liftIO $ trace_if logger (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual)
|
| 1687 | - let mhome_unit = hsc_home_unit_maybe hsc_env
|
|
| 1687 | + let home_unit = hsc_home_unit hsc_env
|
|
| 1688 | 1688 | let dflags = hsc_dflags hsc_env
|
| 1689 | 1689 | let sec = initSourceErrorContext dflags
|
| 1690 | 1690 | case pkgqual of
|
| ... | ... | @@ -1695,7 +1695,7 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do |
| 1695 | 1695 | Nothing -> liftIO $ do
|
| 1696 | 1696 | res <- findImportedModule hsc_env LookupUser mod_name pkgqual
|
| 1697 | 1697 | case res of
|
| 1698 | - Found loc m | notHomeModuleMaybe mhome_unit m -> return m
|
|
| 1698 | + Found loc m | notHomeModule home_unit m -> return m
|
|
| 1699 | 1699 | | otherwise -> modNotLoadedError dflags m loc
|
| 1700 | 1700 | err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err
|
| 1701 | 1701 |
| ... | ... | @@ -470,7 +470,7 @@ addUnit u = do |
| 470 | 470 | , ue_home_unit_graph =
|
| 471 | 471 | HUG.unitEnv_singleton
|
| 472 | 472 | (homeUnitId home_unit)
|
| 473 | - (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) (Just home_unit))
|
|
| 473 | + (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) home_unit)
|
|
| 474 | 474 | , ue_eps = ue_eps old_unit_env
|
| 475 | 475 | , ue_module_graph = ue_module_graph old_unit_env
|
| 476 | 476 | , ue_uic = ue_uic old_unit_env
|
| ... | ... | @@ -7,7 +7,6 @@ module GHC.Driver.Env |
| 7 | 7 | , hscUpdateFlags
|
| 8 | 8 | , hscSetFlags
|
| 9 | 9 | , hsc_home_unit
|
| 10 | - , hsc_home_unit_maybe
|
|
| 11 | 10 | , hsc_units
|
| 12 | 11 | , hsc_HPT
|
| 13 | 12 | , hsc_HUE
|
| ... | ... | @@ -122,10 +121,7 @@ runInteractiveHsc :: HscEnv -> Hsc a -> IO a |
| 122 | 121 | runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)
|
| 123 | 122 | |
| 124 | 123 | hsc_home_unit :: HscEnv -> HomeUnit
|
| 125 | -hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env
|
|
| 126 | - |
|
| 127 | -hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit
|
|
| 128 | -hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
|
|
| 124 | +hsc_home_unit = ue_homeUnit . hsc_unit_env
|
|
| 129 | 125 | |
| 130 | 126 | hsc_units :: HasDebugCallStack => HscEnv -> UnitState
|
| 131 | 127 | hsc_units = ue_homeUnitState . hsc_unit_env
|
| ... | ... | @@ -390,7 +386,7 @@ lookupIfaceByModuleHsc hsc_env mod = do |
| 390 | 386 | lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod
|
| 391 | 387 | |
| 392 | 388 | mainModIs :: HomeUnitEnv -> Module
|
| 393 | -mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))
|
|
| 389 | +mainModIs hue = mkHomeModule (homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))
|
|
| 394 | 390 | |
| 395 | 391 | -- | Retrieve the target code interpreter
|
| 396 | 392 | --
|
| ... | ... | @@ -112,7 +112,7 @@ newHscEnv top_dir dflags = do |
| 112 | 112 | where
|
| 113 | 113 | home_unit_graph hpt = HUG.unitEnv_singleton
|
| 114 | 114 | (homeUnitId_ dflags)
|
| 115 | - (HUG.mkHomeUnitEnv emptyUnitState dflags hpt Nothing)
|
|
| 115 | + (HUG.mkHomeUnitEnv emptyUnitState dflags hpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing))
|
|
| 116 | 116 | |
| 117 | 117 | newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
|
| 118 | 118 | newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do
|
| ... | ... | @@ -1672,7 +1672,7 @@ maybeRehydrateBefore hsc_env mni (Just mns) = do |
| 1672 | 1672 | |
| 1673 | 1673 | where
|
| 1674 | 1674 | initialise_knot_var hsc_env = liftIO $
|
| 1675 | - let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni)
|
|
| 1675 | + let mod_name = homeModuleInstantiation (hsc_home_unit hsc_env) (moduleNodeInfoModule mni)
|
|
| 1676 | 1676 | in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv
|
| 1677 | 1677 | |
| 1678 | 1678 | rehydrateAfter :: HscEnv
|
| ... | ... | @@ -373,7 +373,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do |
| 373 | 373 | let dflags = hsc_dflags hsc_env
|
| 374 | 374 | let logger = hsc_logger hsc_env
|
| 375 | 375 | let unit_env = hsc_unit_env hsc_env
|
| 376 | - let home_unit = hsc_home_unit_maybe hsc_env
|
|
| 376 | + let home_unit = hsc_home_unit hsc_env
|
|
| 377 | 377 | let tmpfs = hsc_tmpfs hsc_env
|
| 378 | 378 | let tmpdir = tmpDir dflags
|
| 379 | 379 | let platform = ue_platform unit_env
|
| ... | ... | @@ -473,12 +473,11 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do |
| 473 | 473 | -- These symbols are imported into the stub.c file via RtsAPI.h, and the
|
| 474 | 474 | -- way we do the import depends on whether we're currently compiling
|
| 475 | 475 | -- the base package or not.
|
| 476 | - ++ (case home_unit of
|
|
| 477 | - Just hu
|
|
| 478 | - | isHomeUnitId hu ghcInternalUnitId
|
|
| 479 | - , platformOS platform == OSMinGW32
|
|
| 480 | - -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"]
|
|
| 481 | - _ -> [])
|
|
| 476 | + ++ (if
|
|
| 477 | + | isHomeUnitId home_unit ghcInternalUnitId
|
|
| 478 | + , platformOS platform == OSMinGW32
|
|
| 479 | + -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"]
|
|
| 480 | + | otherwise -> [])
|
|
| 482 | 481 | |
| 483 | 482 | -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
|
| 484 | 483 | ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
|
| ... | ... | @@ -17,9 +17,9 @@ import GHC.Driver.Config.Diagnostic |
| 17 | 17 | |
| 18 | 18 | import GHC.Unit.Env
|
| 19 | 19 | import GHC.Unit (UnitId)
|
| 20 | +import GHC.Unit.Home (homeUnitId)
|
|
| 20 | 21 | import GHC.Unit.Home.PackageTable
|
| 21 | 22 | import qualified GHC.Unit.Home.Graph as HUG
|
| 22 | -import GHC.Unit.State ( emptyUnitState )
|
|
| 23 | 23 | import qualified GHC.Unit.State as State
|
| 24 | 24 | |
| 25 | 25 | import GHC.Types.SrcLoc
|
| ... | ... | @@ -125,23 +125,24 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do |
| 125 | 125 | |
| 126 | 126 | checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))
|
| 127 | 127 | |
| 128 | - (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags
|
|
| 129 | - let home_units = HUG.allUnits initial_home_graph
|
|
| 128 | + let home_units = Set.fromList $ map homeUnitId_ $ NE.toList unitDflags
|
|
| 130 | 129 | |
| 131 | - home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
|
|
| 132 | - let hue_flags = homeUnitEnv_dflags homeUnitEnv
|
|
| 133 | - dflags = homeUnitEnv_dflags homeUnitEnv
|
|
| 134 | - (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) home_units
|
|
| 130 | + home_unit_envs <- forM unitDflags $ \dflags -> do
|
|
| 131 | + emptyHpt <- liftIO $ emptyHomePackageTable
|
|
| 132 | + (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger dflags (hscUIC hsc_env) home_units
|
|
| 135 | 133 | |
| 136 | 134 | updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
|
| 137 | - emptyHpt <- liftIO $ emptyHomePackageTable
|
|
| 138 | 135 | pure $ HomeUnitEnv
|
| 139 | 136 | { homeUnitEnv_units = unit_state
|
| 140 | 137 | , homeUnitEnv_dflags = updated_dflags
|
| 141 | 138 | , homeUnitEnv_hpt = emptyHpt
|
| 142 | - , homeUnitEnv_home_unit = Just home_unit
|
|
| 139 | + , homeUnitEnv_home_unit = home_unit
|
|
| 143 | 140 | }
|
| 144 | 141 | |
| 142 | + |
|
| 143 | + let mainUnitId = homeUnitId $ homeUnitEnv_home_unit $ NE.head home_unit_envs
|
|
| 144 | + let home_unit_graph = HUG.hugFromHomeUnitEnvs $ NE.toList home_unit_envs
|
|
| 145 | + |
|
| 145 | 146 | checkUnitCycles initial_dflags home_unit_graph
|
| 146 | 147 | |
| 147 | 148 | let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph
|
| ... | ... | @@ -230,16 +231,3 @@ offsetDynFlags dflags = |
| 230 | 231 | augment_maybe (Just f) = Just (augment f)
|
| 231 | 232 | augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f
|
| 232 | 233 | | otherwise = f |
| 233 | - |
|
| 234 | - |
|
| 235 | -createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)
|
|
| 236 | -createUnitEnvFromFlags unitDflags = do
|
|
| 237 | - unitEnvList <- forM unitDflags $ \dflags -> do
|
|
| 238 | - emptyHpt <- emptyHomePackageTable
|
|
| 239 | - let newInternalUnitEnv =
|
|
| 240 | - HUG.mkHomeUnitEnv emptyUnitState dflags emptyHpt Nothing
|
|
| 241 | - return (homeUnitId_ dflags, newInternalUnitEnv)
|
|
| 242 | - let activeUnit = fst $ NE.head unitEnvList
|
|
| 243 | - return (HUG.hugFromList (NE.toList unitEnvList), activeUnit)
|
|
| 244 | - |
|
| 245 | - |
| ... | ... | @@ -82,7 +82,7 @@ mkUsageInfo uc plugins fc unit_env |
| 82 | 82 | = do
|
| 83 | 83 | file_hashes <- liftIO $ mapM getFileHash dependent_files
|
| 84 | 84 | dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs
|
| 85 | - let hu = ue_unsafeHomeUnit unit_env
|
|
| 85 | + let hu = ue_homeUnit unit_env
|
|
| 86 | 86 | -- Dependencies on object files due to TH and plugins
|
| 87 | 87 | object_usages <- liftIO $ mkObjectUsage plugins fc needed_links needed_pkgs
|
| 88 | 88 | let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env)
|
| ... | ... | @@ -27,20 +27,20 @@ badIfaceFile file err |
| 27 | 27 | = vcat [text "Bad interface file:" <+> text file,
|
| 28 | 28 | nest 4 err]
|
| 29 | 29 | |
| 30 | -cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile
|
|
| 30 | +cannotFindInterface :: UnitState -> HomeUnit -> Profile
|
|
| 31 | 31 | -> ModuleName -> InstalledFindResult -> MissingInterfaceError
|
| 32 | -cannotFindInterface us mhu p mn ifr =
|
|
| 32 | +cannotFindInterface us hu p mn ifr =
|
|
| 33 | 33 | CantFindErr us FindingInterface $
|
| 34 | - cantFindInstalledErr us mhu p mn ifr
|
|
| 34 | + cantFindInstalledErr us hu p mn ifr
|
|
| 35 | 35 | |
| 36 | 36 | cantFindInstalledErr
|
| 37 | 37 | :: UnitState
|
| 38 | - -> Maybe HomeUnit
|
|
| 38 | + -> HomeUnit
|
|
| 39 | 39 | -> Profile
|
| 40 | 40 | -> ModuleName
|
| 41 | 41 | -> InstalledFindResult
|
| 42 | 42 | -> CantFindInstalled
|
| 43 | -cantFindInstalledErr unit_state mhome_unit profile mod_name find_result
|
|
| 43 | +cantFindInstalledErr unit_state home_unit profile mod_name find_result
|
|
| 44 | 44 | = CantFindInstalled mod_name more_info
|
| 45 | 45 | where
|
| 46 | 46 | build_tag = waysBuildTag (profileWays profile)
|
| ... | ... | @@ -52,7 +52,7 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result |
| 52 | 52 | |
| 53 | 53 | InstalledNotFound files mb_pkg
|
| 54 | 54 | | Just pkg <- mb_pkg
|
| 55 | - , notHomeUnitId mhome_unit pkg
|
|
| 55 | + , not (isHomeUnitId home_unit pkg)
|
|
| 56 | 56 | -> not_found_in_package pkg $ fmap unsafeDecodeUtf files
|
| 57 | 57 | |
| 58 | 58 | | null files
|
| ... | ... | @@ -102,7 +102,7 @@ cantFindErr _ _ mod_name (FoundMultiple mods) |
| 102 | 102 | cantFindErr unit_env profile mod_name find_result
|
| 103 | 103 | = CantFindInstalled mod_name more_info
|
| 104 | 104 | where
|
| 105 | - mhome_unit = ue_homeUnit unit_env
|
|
| 105 | + home_unit = ue_homeUnit unit_env
|
|
| 106 | 106 | more_info
|
| 107 | 107 | = case find_result of
|
| 108 | 108 | NoPackage pkg
|
| ... | ... | @@ -111,12 +111,7 @@ cantFindErr unit_env profile mod_name find_result |
| 111 | 111 | , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
|
| 112 | 112 | , fr_unusables = unusables, fr_suggestions = suggest }
|
| 113 | 113 | | Just pkg <- mb_pkg
|
| 114 | - , Nothing <- mhome_unit -- no home-unit
|
|
| 115 | - -> not_found_in_package (toUnitId pkg) files
|
|
| 116 | - |
|
| 117 | - | Just pkg <- mb_pkg
|
|
| 118 | - , Just home_unit <- mhome_unit -- there is a home-unit but the
|
|
| 119 | - , not (isHomeUnit home_unit pkg) -- module isn't from it
|
|
| 114 | + , not (isHomeUnit home_unit pkg) -- module isn't from this home unit
|
|
| 120 | 115 | -> not_found_in_package (toUnitId pkg) files
|
| 121 | 116 | |
| 122 | 117 | | not (null suggest)
|
| ... | ... | @@ -774,14 +774,14 @@ loadInterface doc_str mod from |
| 774 | 774 | |
| 775 | 775 | -- Check whether we have the interface already
|
| 776 | 776 | ; hsc_env <- getTopEnv
|
| 777 | - ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)
|
|
| 777 | + ; let home_unit = ue_homeUnit (hsc_unit_env hsc_env)
|
|
| 778 | 778 | ; liftIO (lookupIfaceByModule hug (eps_PIT eps) mod) >>= \case {
|
| 779 | 779 | Just iface
|
| 780 | 780 | -> return (Succeeded iface) ; -- Already loaded
|
| 781 | 781 | _ -> do {
|
| 782 | 782 | |
| 783 | 783 | -- READ THE MODULE IN
|
| 784 | - ; read_result <- case wantHiBootFile mhome_unit eps mod from of
|
|
| 784 | + ; read_result <- case wantHiBootFile home_unit eps mod from of
|
|
| 785 | 785 | Failed err -> return (Failed err)
|
| 786 | 786 | Succeeded hi_boot_file -> do
|
| 787 | 787 | hsc_env <- getTopEnv
|
| ... | ... | @@ -877,7 +877,7 @@ loadInterface doc_str mod from |
| 877 | 877 | |
| 878 | 878 | ; warnPprTrace bad_boot "loadInterface" (ppr mod) $
|
| 879 | 879 | updateEps_ $ \ eps ->
|
| 880 | - if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
|
|
| 880 | + if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface
|
|
| 881 | 881 | then eps
|
| 882 | 882 | else if bad_boot
|
| 883 | 883 | -- See Note [Loading your own hi-boot file]
|
| ... | ... | @@ -1042,12 +1042,12 @@ dontLeakTheHUG thing_inside = do |
| 1042 | 1042 | -- | Returns @True@ if a 'ModIface' comes from an external package.
|
| 1043 | 1043 | -- In this case, we should NOT load it into the EPS; the entities
|
| 1044 | 1044 | -- should instead come from the local merged signature interface.
|
| 1045 | -is_external_sig :: Maybe HomeUnit -> ModIface -> Bool
|
|
| 1046 | -is_external_sig mhome_unit iface =
|
|
| 1045 | +is_external_sig :: HomeUnit -> ModIface -> Bool
|
|
| 1046 | +is_external_sig home_unit iface =
|
|
| 1047 | 1047 | -- It's a signature iface...
|
| 1048 | 1048 | mi_semantic_module iface /= mi_module iface &&
|
| 1049 | 1049 | -- and it's not from the local package
|
| 1050 | - notHomeModuleMaybe mhome_unit (mi_module iface)
|
|
| 1050 | + notHomeModule home_unit (mi_module iface)
|
|
| 1051 | 1051 | |
| 1052 | 1052 | -- | This is an improved version of 'findAndReadIface' which can also
|
| 1053 | 1053 | -- handle the case when a user requests @p[A=<B>]:M@ but we only
|
| ... | ... | @@ -1071,13 +1071,12 @@ computeInterface |
| 1071 | 1071 | -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
|
| 1072 | 1072 | computeInterface hsc_env doc_str hi_boot_file mod0 = do
|
| 1073 | 1073 | massert (not (isHoleModule mod0))
|
| 1074 | - let mhome_unit = hsc_home_unit_maybe hsc_env
|
|
| 1074 | + let home_unit = hsc_home_unit hsc_env
|
|
| 1075 | 1075 | let find_iface m = findAndReadIface hsc_env doc_str
|
| 1076 | 1076 | m mod0 hi_boot_file
|
| 1077 | 1077 | case getModuleInstantiation mod0 of
|
| 1078 | 1078 | (imod, Just indef)
|
| 1079 | - | Just home_unit <- mhome_unit
|
|
| 1080 | - , isHomeUnitIndefinite home_unit ->
|
|
| 1079 | + | isHomeUnitIndefinite home_unit ->
|
|
| 1081 | 1080 | find_iface imod >>= \case
|
| 1082 | 1081 | Succeeded (iface0, path) ->
|
| 1083 | 1082 | rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case
|
| ... | ... | @@ -1134,13 +1133,13 @@ moduleFreeHolesPrecise doc_str mod |
| 1134 | 1133 | return (Succeeded (renameFreeHoles ifhs insts))
|
| 1135 | 1134 | Failed err -> return (Failed err)
|
| 1136 | 1135 | |
| 1137 | -wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom
|
|
| 1136 | +wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom
|
|
| 1138 | 1137 | -> MaybeErr MissingInterfaceError IsBootInterface
|
| 1139 | 1138 | -- Figure out whether we want Foo.hi or Foo.hi-boot
|
| 1140 | -wantHiBootFile mhome_unit eps mod from
|
|
| 1139 | +wantHiBootFile home_unit eps mod from
|
|
| 1141 | 1140 | = case from of
|
| 1142 | 1141 | ImportByUser usr_boot
|
| 1143 | - | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod
|
|
| 1142 | + | usr_boot == IsBoot && notHomeModule home_unit mod
|
|
| 1144 | 1143 | -> Failed (BadSourceImport mod)
|
| 1145 | 1144 | | otherwise -> Succeeded usr_boot
|
| 1146 | 1145 | |
| ... | ... | @@ -1148,7 +1147,7 @@ wantHiBootFile mhome_unit eps mod from |
| 1148 | 1147 | -> Succeeded NotBoot
|
| 1149 | 1148 | |
| 1150 | 1149 | ImportBySystem
|
| 1151 | - | notHomeModuleMaybe mhome_unit mod
|
|
| 1150 | + | notHomeModule home_unit mod
|
|
| 1152 | 1151 | -> Succeeded NotBoot
|
| 1153 | 1152 | -- If the module to be imported is not from this package
|
| 1154 | 1153 | -- don't look it up in eps_is_boot, because that is keyed
|
| ... | ... | @@ -1222,7 +1221,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do |
| 1222 | 1221 | let profile = targetProfile dflags
|
| 1223 | 1222 | unit_state = hsc_units hsc_env
|
| 1224 | 1223 | name_cache = hsc_NC hsc_env
|
| 1225 | - mhome_unit = hsc_home_unit_maybe hsc_env
|
|
| 1224 | + home_unit = hsc_home_unit hsc_env
|
|
| 1226 | 1225 | dflags = hsc_dflags hsc_env
|
| 1227 | 1226 | logger = hsc_logger hsc_env
|
| 1228 | 1227 | hooks = hsc_hooks hsc_env
|
| ... | ... | @@ -1261,7 +1260,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do |
| 1261 | 1260 | trace_if logger (text "...not found")
|
| 1262 | 1261 | return $ Failed $ cannotFindInterface
|
| 1263 | 1262 | unit_state
|
| 1264 | - mhome_unit
|
|
| 1263 | + home_unit
|
|
| 1265 | 1264 | profile
|
| 1266 | 1265 | (moduleName mod)
|
| 1267 | 1266 | err
|
| ... | ... | @@ -160,22 +160,18 @@ get_link_deps opts pls maybe_normal_osuf span mods = do |
| 160 | 160 | = HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case
|
| 161 | 161 | Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info))
|
| 162 | 162 | Nothing -> do
|
| 163 | - -- It's not in the HPT because we are in one shot mode,
|
|
| 164 | - -- so use the Finder to get a ModLocation...
|
|
| 165 | - case ue_homeUnit unit_env of
|
|
| 166 | - Nothing -> no_obj mod
|
|
| 167 | - Just home_unit -> do
|
|
| 168 | - |
|
| 169 | - let fc = ldFinderCache opts
|
|
| 170 | - let fopts = ldFinderOpts opts
|
|
| 171 | - mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
|
|
| 172 | - case mb_stuff of
|
|
| 173 | - Found loc _ -> do
|
|
| 174 | - from_bc <- ldLoadByteCode opts mod loc
|
|
| 175 | - maybe (fallback_no_bytecode home_unit mod) pure from_bc
|
|
| 176 | - _ -> fallback_no_bytecode home_unit mod
|
|
| 163 | + -- It's not in the HPT because we are in one shot mode,
|
|
| 164 | + -- so use the Finder to get a ModLocation...
|
|
| 165 | + let fc = ldFinderCache opts
|
|
| 166 | + let fopts = ldFinderOpts opts
|
|
| 167 | + mb_stuff <- findHomeModule fc fopts hu (moduleName mod)
|
|
| 168 | + case mb_stuff of
|
|
| 169 | + Found loc _ -> do
|
|
| 170 | + from_bc <- ldLoadByteCode opts mod loc
|
|
| 171 | + maybe (fallback_no_bytecode hu mod) pure from_bc
|
|
| 172 | + _ -> fallback_no_bytecode hu mod
|
|
| 177 | 173 | where
|
| 178 | - |
|
| 174 | + hu = ue_homeUnit unit_env
|
|
| 179 | 175 | fallback_no_bytecode home_unit mod = do
|
| 180 | 176 | let fc = ldFinderCache opts
|
| 181 | 177 | let fopts = ldFinderOpts opts
|
| ... | ... | @@ -487,7 +487,7 @@ renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual |
| 487 | 487 | renamePkgQual unit_env mn mb_pkg = case mb_pkg of
|
| 488 | 488 | Nothing -> NoPkgQual
|
| 489 | 489 | Just pkg_fs
|
| 490 | - | Just uid <- homeUnitId <$> ue_homeUnit unit_env
|
|
| 490 | + | uid <- homeUnitId (ue_homeUnit unit_env)
|
|
| 491 | 491 | , pkg_fs == fsLit "this"
|
| 492 | 492 | -> ThisPkg uid
|
| 493 | 493 |
| ... | ... | @@ -485,17 +485,15 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache |
| 485 | 485 | let load_info mod = do
|
| 486 | 486 | -- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps.
|
| 487 | 487 | linkable <- HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case
|
| 488 | - Nothing ->
|
|
| 488 | + Nothing -> do
|
|
| 489 | 489 | -- It's not in the HPT because we are in one shot mode,
|
| 490 | 490 | -- so use the Finder to get a ModLocation...
|
| 491 | - case ue_homeUnit unit_env of
|
|
| 492 | - Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod)
|
|
| 493 | - Just home_unit -> do
|
|
| 494 | - mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod)
|
|
| 495 | - case mb_stuff of
|
|
| 496 | - Found loc mod -> found loc mod
|
|
| 497 | - _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
|
|
| 491 | + mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod)
|
|
| 492 | + case mb_stuff of
|
|
| 493 | + Found loc mod -> found loc mod
|
|
| 494 | + _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod)
|
|
| 498 | 495 | where
|
| 496 | + home_unit = ue_homeUnit unit_env
|
|
| 499 | 497 | found loc mod = do {
|
| 500 | 498 | mb_lnk <- findObjectLinkableMaybe mod loc ;
|
| 501 | 499 | case mb_lnk of {
|
| ... | ... | @@ -286,11 +286,11 @@ implicitRequirements hsc_env normal_imports |
| 286 | 286 | forM normal_imports $ \e -> do
|
| 287 | 287 | found <- resolveImport hsc_env e
|
| 288 | 288 | case found of
|
| 289 | - Found _ mod | notHomeModuleMaybe mhome_unit mod ->
|
|
| 289 | + Found _ mod | notHomeModule home_unit mod ->
|
|
| 290 | 290 | return (uniqDSetToList (moduleFreeHoles mod))
|
| 291 | 291 | _ -> return []
|
| 292 | 292 | where
|
| 293 | - mhome_unit = hsc_home_unit_maybe hsc_env
|
|
| 293 | + home_unit = hsc_home_unit hsc_env
|
|
| 294 | 294 | |
| 295 | 295 | -- | Like @implicitRequirements'@, but returns the instantiated unit the
|
| 296 | 296 | -- imported module is from, so that that instantiated unit can be processed and
|
| ... | ... | @@ -302,13 +302,13 @@ implicitRequirementsShallow |
| 302 | 302 | -> IO [InstantiatedUnit]
|
| 303 | 303 | implicitRequirementsShallow hsc_env normal_imports = go [] normal_imports
|
| 304 | 304 | where
|
| 305 | - mhome_unit = hsc_home_unit_maybe hsc_env
|
|
| 305 | + home_unit = hsc_home_unit hsc_env
|
|
| 306 | 306 | |
| 307 | 307 | go acc [] = pure acc
|
| 308 | 308 | go accR (e:imports) = do
|
| 309 | 309 | found <- resolveImport hsc_env e
|
| 310 | 310 | let acc' = case found of
|
| 311 | - Found _ mod | notHomeModuleMaybe mhome_unit mod ->
|
|
| 311 | + Found _ mod | notHomeModule home_unit mod ->
|
|
| 312 | 312 | case moduleUnit mod of
|
| 313 | 313 | HoleUnit -> panic "implicitRequirementsShallow: HoleUnit is unreachable through findImportedModule!"
|
| 314 | 314 | RealUnit _ -> accR
|
| ... | ... | @@ -180,8 +180,8 @@ lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) |
| 180 | 180 | lookupGlobal_maybe hsc_env name
|
| 181 | 181 | = do { -- Try local envt
|
| 182 | 182 | let mod = icInteractiveModule (hsc_IC hsc_env)
|
| 183 | - mhome_unit = hsc_home_unit_maybe hsc_env
|
|
| 184 | - tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
|
|
| 183 | + home_unit = hsc_home_unit hsc_env
|
|
| 184 | + tcg_semantic_mod = homeModuleInstantiation home_unit mod
|
|
| 185 | 185 | |
| 186 | 186 | ; if nameIsLocalOrFrom tcg_semantic_mod name
|
| 187 | 187 | then return $ Failed $ Left name
|
| ... | ... | @@ -371,7 +371,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = |
| 371 | 371 | ; let
|
| 372 | 372 | -- bangs to avoid leaking the env (#19356)
|
| 373 | 373 | !dflags = hsc_dflags hsc_env
|
| 374 | - !mhome_unit = hsc_home_unit_maybe hsc_env
|
|
| 374 | + !home_unit = hsc_home_unit hsc_env
|
|
| 375 | 375 | !logger = hsc_logger hsc_env
|
| 376 | 376 | |
| 377 | 377 | maybe_rn_syntax :: forall a. a -> Maybe a ;
|
| ... | ... | @@ -399,7 +399,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = |
| 399 | 399 | , tcg_th_docs = th_docs_var
|
| 400 | 400 | |
| 401 | 401 | , tcg_mod = mod
|
| 402 | - , tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
|
|
| 402 | + , tcg_semantic_mod = homeModuleInstantiation home_unit mod
|
|
| 403 | 403 | , tcg_src = hsc_src
|
| 404 | 404 | , tcg_rdr_env = emptyGlobalRdrEnv
|
| 405 | 405 | , tcg_fix_env = emptyNameEnv
|
| ... | ... | @@ -2574,11 +2574,11 @@ initIfaceTcRn thing_inside |
| 2574 | 2574 | = do { tcg_env <- getGblEnv
|
| 2575 | 2575 | ; hsc_env <- getTopEnv
|
| 2576 | 2576 | -- bangs to avoid leaking the envs (#19356)
|
| 2577 | - ; let !mhome_unit = hsc_home_unit_maybe hsc_env
|
|
| 2577 | + ; let !home_unit = hsc_home_unit hsc_env
|
|
| 2578 | 2578 | !knot_vars = tcg_knot_vars tcg_env
|
| 2579 | 2579 | -- When we are instantiating a signature,
|
| 2580 | 2580 | -- we DEFINITELY do not want to knot tie.
|
| 2581 | - is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit)
|
|
| 2581 | + is_instantiate = isHomeUnitInstantiating home_unit
|
|
| 2582 | 2582 | |
| 2583 | 2583 | if_env = IfGblEnv { if_doc = text "initIfaceTcRn"
|
| 2584 | 2584 | , if_rec_types = if is_instantiate
|
| ... | ... | @@ -53,7 +53,6 @@ module GHC.Unit.Env |
| 53 | 53 | , ue_unitHomeUnit_maybe
|
| 54 | 54 | , ue_updateHomeUnitEnv
|
| 55 | 55 | , ue_all_home_unit_ids
|
| 56 | - , ue_unsafeHomeUnit
|
|
| 57 | 56 | |
| 58 | 57 | -- * HUG Re-export
|
| 59 | 58 | , HomeUnitGraph
|
| ... | ... | @@ -235,14 +234,13 @@ preloadUnitsInfo' unit_env ids0 = all_infos |
| 235 | 234 | where
|
| 236 | 235 | unit_state = HUG.homeUnitEnv_units (ue_currentHomeUnitEnv unit_env)
|
| 237 | 236 | ids = ids0 ++ inst_ids
|
| 238 | - inst_ids = case ue_homeUnit unit_env of
|
|
| 239 | - Nothing -> []
|
|
| 240 | - Just home_unit
|
|
| 241 | - -- An indefinite package will have insts to HOLE,
|
|
| 242 | - -- which is not a real package. Don't look it up.
|
|
| 243 | - -- Fixes #14525
|
|
| 244 | - | isHomeUnitIndefinite home_unit -> []
|
|
| 245 | - | otherwise -> map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)
|
|
| 237 | + home_unit = ue_homeUnit unit_env
|
|
| 238 | + inst_ids
|
|
| 239 | + -- An indefinite package will have insts to HOLE,
|
|
| 240 | + -- which is not a real package. Don't look it up.
|
|
| 241 | + -- Fixes #14525
|
|
| 242 | + | isHomeUnitIndefinite home_unit = []
|
|
| 243 | + | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)
|
|
| 246 | 244 | pkg_map = unitInfoMap unit_state
|
| 247 | 245 | preload = preloadUnits unit_state
|
| 248 | 246 | |
| ... | ... | @@ -320,20 +318,15 @@ ue_setFlags dflags env = |
| 320 | 318 | -- Query and modify home units in HomeUnitEnv
|
| 321 | 319 | -- -------------------------------------------------------
|
| 322 | 320 | |
| 323 | -ue_homeUnit :: UnitEnv -> Maybe HomeUnit
|
|
| 321 | +ue_homeUnit :: UnitEnv -> HomeUnit
|
|
| 324 | 322 | ue_homeUnit = HUG.homeUnitEnv_home_unit . ue_currentHomeUnitEnv
|
| 325 | 323 | |
| 326 | -ue_unsafeHomeUnit :: UnitEnv -> HomeUnit
|
|
| 327 | -ue_unsafeHomeUnit ue = case ue_homeUnit ue of
|
|
| 328 | - Nothing -> panic "ue_unsafeHomeUnit: No home unit"
|
|
| 329 | - Just h -> h
|
|
| 330 | - |
|
| 331 | 324 | ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit
|
| 332 | 325 | ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid
|
| 333 | 326 | |
| 334 | 327 | ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit
|
| 335 | 328 | ue_unitHomeUnit_maybe uid ue_env =
|
| 336 | - HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env)
|
|
| 329 | + HUG.homeUnitEnv_home_unit <$> HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env)
|
|
| 337 | 330 | |
| 338 | 331 | -- -------------------------------------------------------
|
| 339 | 332 | -- Query and modify the currently active unit
|
| ... | ... | @@ -5,6 +5,7 @@ |
| 5 | 5 | |
| 6 | 6 | |
| 7 | 7 | {-# LANGUAGE RecordWildCards #-}
|
| 8 | +{-# LANGUAGE MultiWayIf #-}
|
|
| 8 | 9 | |
| 9 | 10 | -- | Module finder
|
| 10 | 11 | module GHC.Unit.Finder (
|
| ... | ... | @@ -210,7 +211,7 @@ findImportedModule |
| 210 | 211 | -> IO FindResult
|
| 211 | 212 | findImportedModule hsc_env scope mod pkg_qual =
|
| 212 | 213 | let fc = hsc_FC hsc_env
|
| 213 | - mb_home_unit = hsc_home_unit_maybe hsc_env
|
|
| 214 | + home_unit = hsc_home_unit hsc_env
|
|
| 214 | 215 | dflags = hsc_dflags hsc_env
|
| 215 | 216 | fopts = initFinderOpts dflags
|
| 216 | 217 | providers = mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env)
|
| ... | ... | @@ -220,7 +221,7 @@ findImportedModule hsc_env scope mod pkg_qual = |
| 220 | 221 | fopts
|
| 221 | 222 | (hsc_unit_env hsc_env)
|
| 222 | 223 | providers
|
| 223 | - mb_home_unit
|
|
| 224 | + home_unit
|
|
| 224 | 225 | scope
|
| 225 | 226 | mod
|
| 226 | 227 | pkg_qual
|
| ... | ... | @@ -230,33 +231,30 @@ findImportedModuleNoHsc |
| 230 | 231 | -> FinderOpts
|
| 231 | 232 | -> UnitEnv
|
| 232 | 233 | -> HomeModuleNameProvidersMap
|
| 233 | - -> Maybe HomeUnit
|
|
| 234 | + -> HomeUnit
|
|
| 234 | 235 | -> ModuleLookupScope
|
| 235 | 236 | -> ModuleName
|
| 236 | 237 | -> PkgQual
|
| 237 | 238 | -> IO FindResult
|
| 238 | -findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name mb_pkg =
|
|
| 239 | +findImportedModuleNoHsc fc fopts ue home_module_name_providers_map home_unit scope mod_name mb_pkg =
|
|
| 239 | 240 | case mb_pkg of
|
| 240 | 241 | NoPkgQual -> unqual_import
|
| 241 | - ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import
|
|
| 242 | + ThisPkg uid | homeUnitId home_unit == uid -> home_import
|
|
| 242 | 243 | | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
|
| 243 | - | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts))
|
|
| 244 | + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr home_unit_id $$ ppr uid $$ ppr (map fst all_opts))
|
|
| 244 | 245 | OtherPkg _ -> pkg_import
|
| 245 | 246 | where
|
| 246 | 247 | |
| 247 | - mb_home_unit_id :: Maybe UnitId
|
|
| 248 | - mb_home_unit_id = homeUnitId <$> mb_home_unit
|
|
| 248 | + home_unit_id :: UnitId
|
|
| 249 | + home_unit_id = homeUnitId home_unit
|
|
| 249 | 250 | |
| 250 | 251 | all_opts :: [(UnitId, FinderOpts)]
|
| 251 | - all_opts = case mb_home_unit_id of
|
|
| 252 | - Nothing -> other_fopts
|
|
| 253 | - Just home_unit_id -> (home_unit_id, fopts) : other_fopts
|
|
| 252 | + all_opts =
|
|
| 253 | + (home_unit_id, fopts) : other_fopts
|
|
| 254 | 254 | |
| 255 | 255 | home_import :: IO FindResult
|
| 256 | - home_import = case mb_home_unit of
|
|
| 257 | - Just home_unit -> findHomeModule fc fopts home_unit mod_name
|
|
| 258 | - Nothing -> pure $
|
|
| 259 | - NoPackage (panic "findImportedModule: no home-unit")
|
|
| 256 | + home_import =
|
|
| 257 | + findHomeModule fc fopts home_unit mod_name
|
|
| 260 | 258 | |
| 261 | 259 | home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult
|
| 262 | 260 | home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name
|
| ... | ... | @@ -266,13 +264,11 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit |
| 266 | 264 | |
| 267 | 265 | unqual_import :: IO FindResult
|
| 268 | 266 | unqual_import = findHomeOrRegularPackageModule fc fopts ue
|
| 269 | - home_module_name_providers_map mb_home_unit scope mod_name
|
|
| 267 | + home_module_name_providers_map home_unit scope mod_name
|
|
| 270 | 268 | |
| 271 | 269 | unit_state :: UnitState
|
| 272 | - unit_state = case mb_home_unit_id of
|
|
| 273 | - Nothing -> ue_homeUnitState ue
|
|
| 274 | - Just home_unit_id -> HUG.homeUnitEnv_units $
|
|
| 275 | - ue_findHomeUnitEnv home_unit_id ue
|
|
| 270 | + unit_state = HUG.homeUnitEnv_units $
|
|
| 271 | + ue_findHomeUnitEnv home_unit_id ue
|
|
| 276 | 272 | |
| 277 | 273 | other_fopts :: [(UnitId, FinderOpts)]
|
| 278 | 274 | other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map
|
| ... | ... | @@ -287,28 +283,26 @@ findPluginModuleNoHsc |
| 287 | 283 | -> FinderOpts
|
| 288 | 284 | -> UnitEnv
|
| 289 | 285 | -> HomeModuleNameProvidersMap
|
| 290 | - -> Maybe HomeUnit
|
|
| 286 | + -> HomeUnit
|
|
| 291 | 287 | -> ModuleName
|
| 292 | 288 | -> IO FindResult
|
| 293 | -findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name =
|
|
| 289 | +findPluginModuleNoHsc fc fopts ue home_module_name_providers_map home_unit mod_name =
|
|
| 294 | 290 | findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
|
| 295 | - mb_home_unit LookupUser mod_name
|
|
| 291 | + home_unit LookupUser mod_name
|
|
| 296 | 292 | `orIfNotFound`
|
| 297 | 293 | findExposedPluginPackageModule fc fopts unit_state mod_name
|
| 298 | 294 | where
|
| 299 | 295 | unit_state = HUG.homeUnitEnv_units $
|
| 300 | 296 | ue_findHomeUnitEnv (homeUnitId home_unit) ue
|
| 301 | -findPluginModuleNoHsc fc fopts ue _ Nothing mod_name =
|
|
| 302 | - findExposedPluginPackageModule fc fopts (ue_homeUnitState ue) mod_name
|
|
| 303 | 297 | |
| 304 | 298 | findPluginModule :: HscEnv -> ModuleName -> IO FindResult
|
| 305 | 299 | findPluginModule hsc_env mod_name = do
|
| 306 | 300 | let fc = hsc_FC hsc_env
|
| 307 | - mb_home_unit = hsc_home_unit_maybe hsc_env
|
|
| 301 | + home_unit = hsc_home_unit hsc_env
|
|
| 308 | 302 | home_module_name_providers_map =
|
| 309 | 303 | mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env)
|
| 310 | 304 | findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env))
|
| 311 | - (hsc_unit_env hsc_env) home_module_name_providers_map mb_home_unit mod_name
|
|
| 305 | + (hsc_unit_env hsc_env) home_module_name_providers_map home_unit mod_name
|
|
| 312 | 306 | |
| 313 | 307 | -- -----------------------------------------------------------------------------
|
| 314 | 308 | -- Home Module Finder Helpers
|
| ... | ... | @@ -380,7 +374,7 @@ findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name (uid, |
| 380 | 374 | | Just real_mod_name
|
| 381 | 375 | <- lookupUniqMap (finder_reexportedModules opts) mod_name
|
| 382 | 376 | = findHomeOrRegularPackageModule fc opts ue home_module_name_providers_map
|
| 383 | - (Just $ DefiniteHomeUnit uid Nothing)
|
|
| 377 | + (DefiniteHomeUnit uid Nothing)
|
|
| 384 | 378 | scope real_mod_name
|
| 385 | 379 | | elementOfUniqSet mod_name (finder_hiddenModules opts)
|
| 386 | 380 | , LookupUser <- scope -- A system lookup is allowed to find hidden modules.
|
| ... | ... | @@ -397,27 +391,22 @@ findHomeModuleAmongDeps |
| 397 | 391 | -> FinderOpts
|
| 398 | 392 | -> UnitEnv
|
| 399 | 393 | -> HomeModuleNameProvidersMap
|
| 400 | - -> Maybe HomeUnit
|
|
| 394 | + -> HomeUnit
|
|
| 401 | 395 | -> ModuleLookupScope
|
| 402 | 396 | -> ModuleName
|
| 403 | 397 | -> IO FindResult
|
| 404 | -findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name =
|
|
| 398 | +findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map home_unit scope mod_name =
|
|
| 405 | 399 | foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts)
|
| 406 | 400 | -- Do not try to be smart and change this to `foldr orIfNotFound home_import
|
| 407 | 401 | -- (map home_pkg_import other_fopts)`, as that would not be the same.
|
| 408 | 402 | -- `home_import` is first because we need to first look within the current
|
| 409 | 403 | -- unit before looking at the other units in order.
|
| 410 | 404 | where
|
| 411 | - home_import = case mb_home_unit of
|
|
| 412 | - Just home_unit -> findHomeModule fc fopts home_unit mod_name
|
|
| 413 | - Nothing -> pure $
|
|
| 414 | - NoPackage (panic "findHomeModuleAmongDeps: no home-unit")
|
|
| 405 | + home_import = findHomeModule fc fopts home_unit mod_name
|
|
| 406 | + |
|
| 415 | 407 | home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name
|
| 416 | 408 | |
| 417 | - unit_state = case homeUnitId <$> mb_home_unit of
|
|
| 418 | - Nothing -> ue_homeUnitState ue
|
|
| 419 | - Just home_unit_id -> HUG.homeUnitEnv_units $
|
|
| 420 | - ue_findHomeUnitEnv home_unit_id ue
|
|
| 409 | + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
|
|
| 421 | 410 | other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map
|
| 422 | 411 | unit_state mod_name
|
| 423 | 412 | |
| ... | ... | @@ -428,33 +417,31 @@ findHomeOrRegularPackageModule |
| 428 | 417 | -> FinderOpts
|
| 429 | 418 | -> UnitEnv
|
| 430 | 419 | -> HomeModuleNameProvidersMap
|
| 431 | - -> Maybe HomeUnit
|
|
| 420 | + -> HomeUnit
|
|
| 432 | 421 | -> ModuleLookupScope
|
| 433 | 422 | -> ModuleName
|
| 434 | 423 | -> IO FindResult
|
| 435 | -findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name =
|
|
| 424 | +findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map home_unit scope mod_name =
|
|
| 436 | 425 | findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
|
| 437 | - mb_home_unit scope mod_name
|
|
| 426 | + home_unit scope mod_name
|
|
| 438 | 427 | `orIfNotFound`
|
| 439 | 428 | findExposedPackageModule fc fopts unit_state scope mod_name NoPkgQual
|
| 440 | 429 | where
|
| 441 | - unit_state = case homeUnitId <$> mb_home_unit of
|
|
| 442 | - Nothing -> ue_homeUnitState ue
|
|
| 443 | - Just home_unit_id -> HUG.homeUnitEnv_units $
|
|
| 444 | - ue_findHomeUnitEnv home_unit_id ue
|
|
| 430 | + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
|
|
| 445 | 431 | |
| 446 | 432 | |
| 447 | 433 | -- | A version of findExactModule which takes the exact parts of the HscEnv it needs
|
| 448 | 434 | -- directly.
|
| 449 | -findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
|
|
| 450 | -findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do
|
|
| 451 | - res <- case mb_home_unit of
|
|
| 452 | - Just home_unit
|
|
| 435 | +findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
|
|
| 436 | +findExactModuleNoHsc fc fopts other_fopts unit_state home_unit mod is_boot = do
|
|
| 437 | + res <-
|
|
| 438 | + if
|
|
| 453 | 439 | | isHomeInstalledModule home_unit mod
|
| 454 | 440 | -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)
|
| 455 | 441 | | Just home_fopts <- HUG.unitEnv_lookup_maybe (moduleUnit mod) other_fopts
|
| 456 | 442 | -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)
|
| 457 | - _ -> findPackageModule fc unit_state fopts mod
|
|
| 443 | + | otherwise
|
|
| 444 | + -> findPackageModule fc unit_state fopts mod
|
|
| 458 | 445 | case (res, is_boot) of
|
| 459 | 446 | (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc))
|
| 460 | 447 | _ -> return res
|
| ... | ... | @@ -470,7 +457,7 @@ findExactModule hsc_env mod is_boot = do |
| 470 | 457 | let dflags = hsc_dflags hsc_env
|
| 471 | 458 | let fc = hsc_FC hsc_env
|
| 472 | 459 | let unit_state = hsc_units hsc_env
|
| 473 | - let home_unit = hsc_home_unit_maybe hsc_env
|
|
| 460 | + let home_unit = hsc_home_unit hsc_env
|
|
| 474 | 461 | let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)
|
| 475 | 462 | findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot
|
| 476 | 463 |
| ... | ... | @@ -18,9 +18,7 @@ module GHC.Unit.Home |
| 18 | 18 | , isHomeUnitInstanceOf
|
| 19 | 19 | , isHomeModule
|
| 20 | 20 | , isHomeInstalledModule
|
| 21 | - , notHomeUnitId
|
|
| 22 | 21 | , notHomeModule
|
| 23 | - , notHomeModuleMaybe
|
|
| 24 | 22 | , notHomeInstalledModule
|
| 25 | 23 | , notHomeInstalledModuleMaybe
|
| 26 | 24 | -- * Helpers
|
| ... | ... | @@ -144,11 +142,6 @@ isHomeUnit hu u = u == homeUnitAsUnit hu |
| 144 | 142 | isHomeUnitId :: GenHomeUnit u -> UnitId -> Bool
|
| 145 | 143 | isHomeUnitId hu uid = uid == homeUnitId hu
|
| 146 | 144 | |
| 147 | --- | Test if the unit-id is not the home unit-id
|
|
| 148 | -notHomeUnitId :: Maybe (GenHomeUnit u) -> UnitId -> Bool
|
|
| 149 | -notHomeUnitId Nothing _ = True
|
|
| 150 | -notHomeUnitId (Just hu) uid = not (isHomeUnitId hu uid)
|
|
| 151 | - |
|
| 152 | 145 | -- | Test if the home unit is an instance of the given unit-id
|
| 153 | 146 | isHomeUnitInstanceOf :: HomeUnit -> UnitId -> Bool
|
| 154 | 147 | isHomeUnitInstanceOf hu u = homeUnitInstanceOf hu == u
|
| ... | ... | @@ -175,10 +168,6 @@ notHomeInstalledModuleMaybe mh m = fromMaybe True $ fmap (`notHomeInstalledModul |
| 175 | 168 | notHomeModule :: HomeUnit -> Module -> Bool
|
| 176 | 169 | notHomeModule hu m = not (isHomeModule hu m)
|
| 177 | 170 | |
| 178 | --- | Test if a module doesn't come from the given home unit
|
|
| 179 | -notHomeModuleMaybe :: Maybe HomeUnit -> Module -> Bool
|
|
| 180 | -notHomeModuleMaybe mh m = fromMaybe True $ fmap (`notHomeModule` m) mh
|
|
| 181 | - |
|
| 182 | 171 | ----------------------------
|
| 183 | 172 | -- helpers
|
| 184 | 173 | ----------------------------
|
| ... | ... | @@ -211,9 +200,8 @@ homeModuleNameInstantiation hu mod_name = |
| 211 | 200 | -- the instantiating module of @r:A@ in @p[A=q[]:B]@ is @r:A@.
|
| 212 | 201 | -- the instantiating module of @p:A@ in @p@ is @p:A@.
|
| 213 | 202 | -- the instantiating module of @r:A@ in @p@ is @r:A@.
|
| 214 | -homeModuleInstantiation :: Maybe HomeUnit -> Module -> Module
|
|
| 215 | -homeModuleInstantiation mhu mod
|
|
| 216 | - | Just hu <- mhu
|
|
| 217 | - , isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod)
|
|
| 203 | +homeModuleInstantiation :: HomeUnit -> Module -> Module
|
|
| 204 | +homeModuleInstantiation hu mod
|
|
| 205 | + | isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod)
|
|
| 218 | 206 | | otherwise = mod
|
| 219 | 207 |
| ... | ... | @@ -50,6 +50,7 @@ module GHC.Unit.Home.Graph |
| 50 | 50 | -- * Utilities
|
| 51 | 51 | , hugSCCs
|
| 52 | 52 | , hugFromList
|
| 53 | + , hugFromHomeUnitEnvs
|
|
| 53 | 54 | |
| 54 | 55 | -- ** Printing
|
| 55 | 56 | , pprHomeUnitGraph
|
| ... | ... | @@ -150,11 +151,11 @@ data HomeUnitEnv = HomeUnitEnv |
| 150 | 151 | --
|
| 151 | 152 | -- (This changes a previous invariant: changed Jan 05.)
|
| 152 | 153 | |
| 153 | - , homeUnitEnv_home_unit :: !(Maybe HomeUnit)
|
|
| 154 | + , homeUnitEnv_home_unit :: !HomeUnit
|
|
| 154 | 155 | -- ^ Home-unit
|
| 155 | 156 | }
|
| 156 | 157 | |
| 157 | -mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
|
|
| 158 | +mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> HomeUnit -> HomeUnitEnv
|
|
| 158 | 159 | mkHomeUnitEnv us dflags hpt home_unit = HomeUnitEnv
|
| 159 | 160 | { homeUnitEnv_units = us
|
| 160 | 161 | , homeUnitEnv_dflags = dflags
|
| ... | ... | @@ -363,6 +364,9 @@ hugSCCs hug = sccs where |
| 363 | 364 | hugFromList :: [(UnitId, HomeUnitEnv)] -> HomeUnitGraph
|
| 364 | 365 | hugFromList = UnitEnvGraph . Map.fromList
|
| 365 | 366 | |
| 367 | +hugFromHomeUnitEnvs :: [HomeUnitEnv] -> HomeUnitGraph
|
|
| 368 | +hugFromHomeUnitEnvs = hugFromList . fmap (\hue -> (homeUnitId $ homeUnitEnv_home_unit hue, hue))
|
|
| 369 | + |
|
| 366 | 370 | pprHomeUnitGraph :: HomeUnitGraph -> IO SDoc
|
| 367 | 371 | pprHomeUnitGraph unitEnv = do
|
| 368 | 372 | docs <- mapM (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv
|
| ... | ... | @@ -372,6 +376,6 @@ pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> IO SDoc |
| 372 | 376 | pprHomeUnitEnv uid env = do
|
| 373 | 377 | hptDoc <- pprHPT $ homeUnitEnv_hpt env
|
| 374 | 378 | return $
|
| 375 | - ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->"
|
|
| 379 | + ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->"
|
|
| 376 | 380 | $$ nest 4 hptDoc
|
| 377 | 381 |
| ... | ... | @@ -861,7 +861,7 @@ installInteractiveHomeUnits dflags = do |
| 861 | 861 | (unit_state,home_unit,_mconstants) <-
|
| 862 | 862 | liftIO $ initUnits logger dflags unit_index all_home_units
|
| 863 | 863 | hpt <- liftIO emptyHomePackageTable
|
| 864 | - pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit))
|
|
| 864 | + pure (HUG.mkHomeUnitEnv unit_state dflags hpt home_unit)
|
|
| 865 | 865 | |
| 866 | 866 | concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag]
|
| 867 | 867 | concatPackageDbStacksUsingLongestCommonPrefix stacks =
|