diff options
-rw-r--r-- | compiler/GHC.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 28 | ||||
-rw-r--r-- | compiler/GHC/Driver/MakeFile.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Iface/Errors.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Iface/Load.hs | 68 | ||||
-rw-r--r-- | compiler/GHC/Iface/Recomp.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/IfaceToCore.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Linker/Loader.hs | 24 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Loader.hs | 14 | ||||
-rw-r--r-- | compiler/GHC/Tc/Plugin.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Backpack.hs | 39 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Env.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Unit/Finder.hs | 30 | ||||
-rw-r--r-- | compiler/GHC/Unit/Home.hs | 13 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 2 | ||||
-rw-r--r-- | ghc/Main.hs | 13 | ||||
-rw-r--r-- | testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs | 2 |
18 files changed, 179 insertions, 141 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 5458f264e4..a8e02e60c0 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1643,25 +1643,25 @@ findModule mod_name maybe_pkg = do findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags + let fc = hsc_FC hsc_env + let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + let units = hsc_units hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags case pkgqual of ThisPkg _ -> do home <- lookupLoadedHomeModule mod_name case home of Just m -> return m Nothing -> liftIO $ do - res <- findImportedModule fc fopts units home_unit mod_name pkgqual + res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual case res of - Found loc m | not (isHomeModule home_unit m) -> return m + Found loc m | notHomeModuleMaybe mhome_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err _ -> liftIO $ do - res <- findImportedModule fc fopts units home_unit mod_name pkgqual + res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 2c86b3c22b..4aa38ff0f6 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -111,6 +111,7 @@ import GHC.Types.Name.Env import GHC.Types.PkgQual import GHC.Unit +import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface @@ -1815,11 +1816,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | otherwise = find_it where - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags - home_unit = hsc_home_unit hsc_env - fc = hsc_FC hsc_env - units = hsc_units hsc_env + dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags + mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + fc = hsc_FC hsc_env + units = hsc_units hsc_env check_hash old_summary location src_fn = checkSummaryHash @@ -1828,7 +1829,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) old_summary location find_it = do - found <- findImportedModule fc fopts units home_unit wanted_mod NoPkgQual + found <- findImportedModule fc fopts units mhome_unit wanted_mod NoPkgQual case found of Found location mod | isJust (ml_hs_file location) -> @@ -1876,10 +1877,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc $ DriverFileModuleNameMismatch pi_mod_name wanted_mod - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $ - let instantiations = homeUnitInstantiations home_unit - in throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc - $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations + let instantiations = fromMaybe [] (homeUnitInstantiations <$> mhome_unit) + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $ + throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc + $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary { nms_src_fn = src_fn @@ -2186,12 +2187,13 @@ executeCompileNode :: Int executeCompileNode k n !old_hmi wait_deps mknot_var mod = do MakeEnv{..} <- ask let mk_mod = case ms_hsc_src mod of - HsigFile -> + HsigFile -> do -- MP: It is probably a bit of a misimplementation in backpack that -- compiling a signature requires an knot_var for that unit. -- If you remove this then a lot of backpack tests fail. - let mod_name = homeModuleInstantiation (hsc_home_unit hsc_env) (ms_mod mod) - in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv + let unit_env = hsc_unit_env hsc_env + let mod_name = homeModuleInstantiation (ue_home_unit unit_env) (ms_mod mod) + mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv _ -> return emptyModuleEnv knot_var <- liftIO $ maybe mk_mod return mknot_var deps <- wait_deps diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 9cf23af831..ffe5a73399 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -36,6 +36,7 @@ import GHC.Utils.TmpFs import GHC.Iface.Load (cannotFindModule) +import GHC.Unit.Env import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph @@ -290,14 +291,14 @@ findDependency :: HscEnv -> Bool -- Record dependency on package modules -> IO (Maybe FilePath) -- Interface file findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags + let fc = hsc_FC hsc_env + let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + let units = hsc_units hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags -- Find the module; this will be fast because -- we've done it once during downsweep - r <- findImportedModule fc fopts units home_unit imp pkg + r <- findImportedModule fc fopts units mhome_unit imp pkg case r of Found loc _ -- Home package: just depend on the .hi or hi-boot file diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs index 29c88731f4..93666ca3d5 100644 --- a/compiler/GHC/Iface/Errors.hs +++ b/compiler/GHC/Iface/Errors.hs @@ -67,7 +67,7 @@ homeModError mod location -- ----------------------------------------------------------------------------- -- Error messages -cannotFindInterface :: UnitState -> HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc +cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for") (text "Ambiguous interface for") @@ -75,13 +75,13 @@ cantFindInstalledErr :: SDoc -> SDoc -> UnitState - -> HomeUnit + -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc -cantFindInstalledErr cannot_find _ unit_state home_unit profile tried_these mod_name find_result +cantFindInstalledErr cannot_find _ unit_state mhome_unit profile tried_these mod_name find_result = cannot_find <+> quotes (ppr mod_name) $$ more_info where @@ -94,7 +94,8 @@ cantFindInstalledErr cannot_find _ unit_state home_unit profile tried_these mod_ text "was found" $$ looks_like_srcpkgid pkg InstalledNotFound files mb_pkg - | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg) + | Just pkg <- mb_pkg + , notHomeUnitId mhome_unit pkg -> not_found_in_package pkg files | null files diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 61ef61c8c4..78005781d4 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -109,7 +109,7 @@ import GHC.Unit.State import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.Finder -import GHC.Unit.Env ( ue_hpt ) +import GHC.Unit.Env import GHC.Data.Maybe @@ -322,8 +322,8 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags let units = hsc_units hsc_env - let home_unit = hsc_home_unit hsc_env - res <- liftIO $ findImportedModule fc fopts units home_unit mod maybe_pkg + let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + res <- liftIO $ findImportedModule fc fopts units mhome_unit mod maybe_pkg case res of Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) -- TODO: Make sure this error message is good @@ -456,7 +456,7 @@ loadInterface doc_str mod from -- Check whether we have the interface already ; hsc_env <- getTopEnv - ; let home_unit = hsc_home_unit hsc_env + ; let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded @@ -466,7 +466,7 @@ loadInterface doc_str mod from _ -> do { -- READ THE MODULE IN - ; read_result <- case (wantHiBootFile home_unit eps mod from) of + ; read_result <- case wantHiBootFile mhome_unit eps mod from of Failed err -> return (Failed err) Succeeded hi_boot_file -> do hsc_env <- getTopEnv @@ -540,7 +540,7 @@ loadInterface doc_str mod from ; warnPprTrace bad_boot (ppr mod) $ updateEps_ $ \ eps -> - if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface + if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface then eps else if bad_boot -- See Note [Loading your own hi-boot file] @@ -680,12 +680,12 @@ dontLeakTheHPT 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 :: HomeUnit -> ModIface -> Bool -is_external_sig home_unit iface = +is_external_sig :: Maybe 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 - not (isHomeModule home_unit (mi_module iface)) + notHomeModuleMaybe 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 @@ -711,21 +711,23 @@ computeInterface hsc_env doc_str hi_boot_file mod0 = do massert (not (isHoleModule mod0)) let name_cache = hsc_NC hsc_env let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env + let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env - let find_iface m = findAndReadIface logger name_cache fc hooks units home_unit dflags doc_str + let find_iface m = findAndReadIface logger name_cache fc hooks units mhome_unit dflags doc_str m mod0 hi_boot_file case getModuleInstantiation mod0 of - (imod, Just indef) | isHomeUnitIndefinite home_unit -> - find_iface imod >>= \case - Succeeded (iface0, path) -> - rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case - Right x -> return (Succeeded (x, path)) - Left errs -> throwErrors (GhcTcRnMessage <$> errs) - Failed err -> return (Failed err) + (imod, Just indef) + | Just home_unit <- mhome_unit + , isHomeUnitIndefinite home_unit -> + find_iface imod >>= \case + Succeeded (iface0, path) -> + rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case + Right x -> return (Succeeded (x, path)) + Left errs -> throwErrors (GhcTcRnMessage <$> errs) + Failed err -> return (Failed err) (mod, _) -> find_iface mod -- | Compute the signatures which must be compiled in order to @@ -765,12 +767,12 @@ moduleFreeHolesPrecise doc_str mod hsc_env <- getTopEnv let nc = hsc_NC hsc_env let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env - mb_iface <- liftIO $ findAndReadIface logger nc fc hooks units home_unit dflags + let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + mb_iface <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot case mb_iface of @@ -782,13 +784,13 @@ moduleFreeHolesPrecise doc_str mod return (Succeeded (renameFreeHoles ifhs insts)) Failed err -> return (Failed err) -wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom +wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr SDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot -wantHiBootFile home_unit eps mod from +wantHiBootFile mhome_unit eps mod from = case from of ImportByUser usr_boot - | usr_boot == IsBoot && notHomeModule home_unit mod + | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod -> Failed (badSourceImport mod) | otherwise -> Succeeded usr_boot @@ -796,7 +798,7 @@ wantHiBootFile home_unit eps mod from -> Succeeded NotBoot ImportBySystem - | notHomeModule home_unit mod + | notHomeModuleMaybe 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 @@ -867,7 +869,7 @@ findAndReadIface -> FinderCache -> Hooks -> UnitState - -> HomeUnit + -> Maybe HomeUnit -> DynFlags -> SDoc -- ^ Reason for loading the iface (used for tracing) -> InstalledModule -- ^ The unique identifier of the on-disk module we're looking for @@ -876,7 +878,7 @@ findAndReadIface -- module we read out. -> IsBootInterface -- ^ Looking for .hi-boot or .hi file -> IO (MaybeErr SDoc (ModIface, FilePath)) -findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str mod wanted_mod hi_boot_file = do +findAndReadIface logger name_cache fc hooks unit_state mhome_unit dflags doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags trace_if logger (sep [hsep [text "Reading", @@ -899,14 +901,16 @@ findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str else do let fopts = initFinderOpts dflags -- Look for the file - mb_found <- liftIO (findExactModule fc fopts unit_state home_unit mod) + mb_found <- liftIO (findExactModule fc fopts unit_state mhome_unit mod) case mb_found of InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do -- See Note [Home module load error] - if isHomeInstalledModule home_unit mod && - not (isOneShot (ghcMode dflags)) - then return (Failed (homeModError mod loc)) - else do + case mhome_unit of + Just home_unit + | isHomeInstalledModule home_unit mod + , not (isOneShot (ghcMode dflags)) + -> return (Failed (homeModError mod loc)) + _ -> do r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) case r of Failed _ @@ -923,7 +927,7 @@ findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str trace_if logger (text "...not found") return $ Failed $ cannotFindInterface unit_state - home_unit + mhome_unit profile (Iface_Errors.mayShowLocations dflags) (moduleName mod) diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 0f7b3f353c..89e10424e3 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -54,6 +54,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Fixity.Env +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State @@ -526,8 +527,8 @@ checkMergedSignatures hsc_env mod_summary iface = do checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface = do - res_normal <- classify_import (findImportedModule fc fopts units home_unit) (ms_textual_imps summary ++ ms_srcimps summary) - res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units home_unit mod) (ms_plugin_imps summary) + res_normal <- classify_import (findImportedModule fc fopts units mhome_unit) (ms_textual_imps summary ++ ms_srcimps summary) + res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of Left recomp -> return recomp Right es -> do @@ -548,7 +549,7 @@ checkDependencies hsc_env summary iface fopts = initFinderOpts dflags logger = hsc_logger hsc_env fc = hsc_FC hsc_env - home_unit = hsc_home_unit hsc_env + mhome_unit = ue_home_unit (hsc_unit_env hsc_env) units = hsc_units hsc_env prev_dep_mods = map gwib_mod $ Set.toAscList $ dep_direct_mods (mi_deps iface) prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) @@ -560,13 +561,14 @@ checkDependencies hsc_env summary iface -- GHC.Prim is very special and doesn't appear in ms_textual_imps but -- ghc-prim will appear in the package dependencies still. In order to not confuse -- the recompilation logic we need to not forget we imported GHC.Prim. - fake_ghc_prim_import = if homeUnitId home_unit == primUnitId - then Left (mkModuleName "GHC.Prim") - else Right ("GHC.Prim", primUnitId) + fake_ghc_prim_import = if notHomeUnitId mhome_unit primUnitId + then Right ("GHC.Prim", primUnitId) + else Left (mkModuleName "GHC.Prim") classify _ (Found _ mod) - | isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod)) + | Just home_unit <- mhome_unit + , isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod)) | otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index a53f070e10..69829358ba 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -65,6 +65,7 @@ import GHC.Core.DataCon import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Ppr +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModDetails @@ -552,12 +553,12 @@ tcHiBootIface hsc_src mod { hsc_env <- getTopEnv ; let nc = hsc_NC hsc_env ; let fc = hsc_FC hsc_env - ; let home_unit = hsc_home_unit hsc_env + ; let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) ; let units = hsc_units hsc_env ; let dflags = hsc_dflags hsc_env ; let logger = hsc_logger hsc_env ; let hooks = hsc_hooks hsc_env - ; read_result <- liftIO $ findAndReadIface logger nc fc hooks units home_unit dflags + ; read_result <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags need (fst (getModuleInstantiation mod)) mod IsBoot -- Hi-boot file diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 2af6f4dfe1..80e303b046 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -723,7 +723,6 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods let pkg = moduleUnit mod deps = mi_deps iface - home_unit = hsc_home_unit hsc_env pkg_deps = dep_direct_pkgs deps (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $ @@ -735,10 +734,11 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) -- - if not (isHomeUnit home_unit pkg) - then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) - else follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods) - acc_mods' acc_pkgs' + case ue_home_unit (hsc_unit_env hsc_env) of + Just home_unit + | isHomeUnit home_unit pkg + -> follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods) acc_mods' acc_pkgs' + _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) where msg = text "need to link module" <+> ppr mod <+> text "due to use of Template Haskell" @@ -765,12 +765,14 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods | otherwise = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - mb_stuff <- findHomeModule fc fopts home_unit mod_name - case mb_stuff of + case ue_home_unit (hsc_unit_env hsc_env) of + Nothing -> no_obj mod_name + Just home_unit -> do + let fc = hsc_FC hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + mb_stuff <- findHomeModule fc fopts home_unit mod_name + case mb_stuff of Found loc mod -> found loc mod _ -> no_obj mod_name where diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 09f34b5e16..5ffaf4aaf2 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -54,6 +54,7 @@ import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Unit.Module ( Module, ModuleName ) import GHC.Unit.Module.ModIface +import GHC.Unit.Env import GHC.Utils.Panic import GHC.Utils.Logger @@ -258,13 +259,14 @@ lessUnsafeCoerce logger context what = do lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - let fc = hsc_FC hsc_env - let units = hsc_units hsc_env - let home_unit = hsc_home_unit hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + let fc = hsc_FC hsc_env + let unit_env = hsc_unit_env hsc_env + let unit_state = ue_units unit_env + let mhome_unit = ue_home_unit unit_env -- First find the unit the module resides in by searching exposed units and home modules - found_module <- findPluginModule fc fopts units home_unit mod_name + found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name case found_module of Found _ mod -> do -- Find the exports of the module diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs index f2d9521a8c..5a4f9a8deb 100644 --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -73,6 +73,7 @@ import GHC.Tc.Types.Evidence ( CoercionHole, EvTerm(..) , EvExpr, EvBindsVar, EvBind, mkGivenEvBind ) import GHC.Types.Var ( EvVar ) +import GHC.Unit.Env import GHC.Unit.Module ( ModuleName, Module ) import GHC.Types.Name ( OccName, Name ) import GHC.Types.TyThing ( TyThing ) @@ -81,7 +82,7 @@ import GHC.Core.TyCon ( TyCon ) import GHC.Core.DataCon ( DataCon ) import GHC.Core.Class ( Class ) import GHC.Driver.Config.Finder ( initFinderOpts ) -import GHC.Driver.Env ( HscEnv(..), hsc_home_unit, hsc_units ) +import GHC.Driver.Env ( HscEnv(..), hsc_units ) import GHC.Utils.Outputable ( SDoc ) import GHC.Core.Type ( Kind, Type, PredType ) import GHC.Types.Id ( Id ) @@ -102,12 +103,12 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do hsc_env <- getTopEnv - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - tcPluginIO $ Finder.findImportedModule fc fopts units home_unit mod_name mb_pkg + let fc = hsc_FC hsc_env + let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + let units = hsc_units hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + tcPluginIO $ Finder.findImportedModule fc fopts units mhome_unit mod_name mb_pkg lookupOrig :: Module -> OccName -> TcPluginM Name lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 5594622100..cf4925d2cb 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -41,6 +41,7 @@ import GHC.Types.Name.Shape import GHC.Types.PkgQual import GHC.Unit +import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface @@ -306,17 +307,17 @@ implicitRequirements :: HscEnv implicitRequirements hsc_env normal_imports = fmap concat $ forM normal_imports $ \(mb_pkg, L _ imp) -> do - found <- findImportedModule fc fopts units home_unit imp mb_pkg + found <- findImportedModule fc fopts units mhome_unit imp mb_pkg case found of - Found _ mod | not (isHomeModule home_unit mod) -> + Found _ mod | notHomeModuleMaybe mhome_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where - fc = hsc_FC hsc_env - home_unit = hsc_home_unit hsc_env - units = hsc_units hsc_env - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags + fc = hsc_FC hsc_env + mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + units = hsc_units hsc_env + dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags -- | 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 @@ -328,17 +329,17 @@ implicitRequirementsShallow -> IO ([ModuleName], [InstantiatedUnit]) implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports where - fc = hsc_FC hsc_env - home_unit = hsc_home_unit hsc_env - units = hsc_units hsc_env - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags + fc = hsc_FC hsc_env + mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + units = hsc_units hsc_env + dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags go acc [] = pure acc go (accL, accR) ((mb_pkg, L _ imp):imports) = do - found <- findImportedModule fc fopts units home_unit imp mb_pkg + found <- findImportedModule fc fopts units mhome_unit imp mb_pkg let acc' = case found of - Found _ mod | not (isHomeModule home_unit mod) -> + Found _ mod | notHomeModuleMaybe mhome_unit mod -> case moduleUnit mod of HoleUnit -> (moduleName mod : accL, accR) RealUnit _ -> (accL, accR) @@ -570,7 +571,7 @@ mergeSignatures let unit_state = hsc_units hsc_env let fc = hsc_FC hsc_env let nc = hsc_NC hsc_env - let home_unit = hsc_home_unit hsc_env + let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env @@ -588,7 +589,7 @@ mergeSignatures ctx = initSDocContext dflags defaultUserStyle fmap fst . withException ctx - $ findAndReadIface logger nc fc hooks unit_state home_unit dflags + $ findAndReadIface logger nc fc hooks unit_state mhome_unit dflags (text "mergeSignatures") im m NotBoot -- STEP 3: Get the unrenamed exports of all these interfaces, @@ -768,6 +769,8 @@ mergeSignatures setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do tcg_env <- getGblEnv + let home_unit = hsc_home_unit hsc_env + -- STEP 4: Rename the interfaces ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) -> tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface @@ -1001,12 +1004,12 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do hsc_env <- getTopEnv let nc = hsc_NC hsc_env let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env + let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env - mb_isig_iface <- liftIO $ findAndReadIface logger nc fc hooks units home_unit dflags + mb_isig_iface <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags (text "checkImplements 2") isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index ad74d919ab..f922e87876 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -106,6 +106,7 @@ import GHC.Core.Class import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.External +import GHC.Unit.Env import GHC.Utils.Outputable import GHC.Utils.Panic @@ -161,8 +162,8 @@ lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) lookupGlobal_maybe hsc_env name = do { -- Try local envt let mod = icInteractiveModule (hsc_IC hsc_env) - home_unit = hsc_home_unit hsc_env - tcg_semantic_mod = homeModuleInstantiation home_unit mod + mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + tcg_semantic_mod = homeModuleInstantiation mhome_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name then (return diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 69ac0c5b59..7aad60649e 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -268,7 +268,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this let { -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env ; - !home_unit = hsc_home_unit hsc_env ; + !mhome_unit = ue_home_unit (hsc_unit_env hsc_env) ; !logger = hsc_logger hsc_env ; maybe_rn_syntax :: forall a. a -> Maybe a ; @@ -296,7 +296,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_th_docs = th_docs_var, tcg_mod = mod, - tcg_semantic_mod = homeModuleInstantiation home_unit mod, + tcg_semantic_mod = homeModuleInstantiation mhome_unit mod, tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, @@ -2073,11 +2073,11 @@ initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv ; hsc_env <- getTopEnv -- bangs to avoid leaking the envs (#19356) - ; let !home_unit = hsc_home_unit hsc_env + ; let !mhome_unit = ue_home_unit (hsc_unit_env 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 = isHomeUnitInstantiating home_unit + is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", if_rec_types = diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs index cc16cd0dad..d4de80947b 100644 --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -134,18 +134,24 @@ findImportedModule :: FinderCache -> FinderOpts -> UnitState - -> HomeUnit + -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModule fc fopts units home_unit mod_name mb_pkg = +findImportedModule fc fopts units mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg _ -> home_import OtherPkg _ -> pkg_import where - home_import = findHomeModule fc fopts home_unit mod_name + home_import + | Just home_unit <- mhome_unit + = findHomeModule fc fopts home_unit mod_name + | otherwise + = pure $ NoPackage (panic "findImportedModule: no home-unit") + pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg + unqual_import = home_import `orIfNotFound` findExposedPackageModule fc fopts units mod_name NoPkgQual @@ -154,11 +160,13 @@ findImportedModule fc fopts units home_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. -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> ModuleName -> IO FindResult -findPluginModule fc fopts units home_unit mod_name = +findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult +findPluginModule fc fopts units (Just home_unit) mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` findExposedPluginPackageModule fc fopts units mod_name +findPluginModule fc fopts units Nothing mod_name = + findExposedPluginPackageModule fc fopts units mod_name -- | Locate a specific 'Module'. The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out @@ -166,11 +174,13 @@ findPluginModule fc fopts units home_unit mod_name = -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: FinderCache -> FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IO InstalledFindResult -findExactModule fc fopts unit_state home_unit mod = do - if isHomeInstalledModule home_unit mod - then findInstalledHomeModule fc fopts home_unit (moduleName mod) - else findPackageModule fc unit_state fopts mod +findExactModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult +findExactModule fc fopts unit_state mhome_unit mod = do + case mhome_unit of + Just home_unit + | isHomeInstalledModule home_unit mod + -> findInstalledHomeModule fc fopts home_unit (moduleName mod) + _ -> findPackageModule fc unit_state fopts mod -- ----------------------------------------------------------------------------- -- Helpers diff --git a/compiler/GHC/Unit/Home.hs b/compiler/GHC/Unit/Home.hs index 02b60e64c9..c72d21e537 100644 --- a/compiler/GHC/Unit/Home.hs +++ b/compiler/GHC/Unit/Home.hs @@ -18,6 +18,7 @@ module GHC.Unit.Home , isHomeUnitInstanceOf , isHomeModule , isHomeInstalledModule + , notHomeUnitId , notHomeModule , notHomeModuleMaybe , notHomeInstalledModule @@ -142,6 +143,11 @@ isHomeUnit hu u = u == homeUnitAsUnit hu isHomeUnitId :: GenHomeUnit u -> UnitId -> Bool isHomeUnitId hu uid = uid == homeUnitId hu +-- | Test if the unit-id is not the home unit-id +notHomeUnitId :: Maybe (GenHomeUnit u) -> UnitId -> Bool +notHomeUnitId Nothing _ = True +notHomeUnitId (Just hu) uid = not (isHomeUnitId hu uid) + -- | Test if the home unit is an instance of the given unit-id isHomeUnitInstanceOf :: HomeUnit -> UnitId -> Bool isHomeUnitInstanceOf hu u = homeUnitInstanceOf hu == u @@ -204,8 +210,9 @@ 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 :: HomeUnit -> Module -> Module -homeModuleInstantiation hu mod - | isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod) +homeModuleInstantiation :: Maybe HomeUnit -> Module -> Module +homeModuleInstantiation mhu mod + | Just hu <- mhu + , isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod) | otherwise = mod diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 362fe0b40a..58bbf4f6fe 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -2041,7 +2041,7 @@ addModule files = do let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags result <- liftIO $ - Finder.findImportedModule fc fopts units home_unit m (ThisPkg (homeUnitId home_unit)) + Finder.findImportedModule fc fopts units (Just home_unit) m (ThisPkg (homeUnitId home_unit)) case result of Found _ _ -> return True _ -> (liftIO $ putStrLn $ diff --git a/ghc/Main.hs b/ghc/Main.hs index 5e6042173f..d00ae72990 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -43,6 +43,7 @@ import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings import GHC.Runtime.Loader ( loadFrontendPlugin ) +import GHC.Unit.Env import GHC.Unit.Module ( ModuleName, mkModuleName ) import GHC.Unit.Module.ModIface import GHC.Unit.State ( pprUnits, pprUnitsSimple ) @@ -872,17 +873,17 @@ abiHash :: [String] -- ^ List of module names -> Ghc () abiHash strs = do hsc_env <- getSession - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags + let fc = hsc_FC hsc_env + let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + let units = hsc_units hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags liftIO $ do let find_it str = do let modname = mkModuleName str - r <- findImportedModule fc fopts units home_unit modname NoPkgQual + r <- findImportedModule fc fopts units mhome_unit modname NoPkgQual case r of Found _ m -> return m _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ diff --git a/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs b/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs index 550a05e116..995b821598 100644 --- a/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs +++ b/testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs @@ -52,7 +52,7 @@ lookupModule mod_nm = do let units = hsc_units hsc_env let home_unit = hsc_home_unit hsc_env -- found_module <- findPluginModule fc fopts units home_unit mod_name - found_module <- tcPluginIO $ findPluginModule fc fopts units home_unit mod_nm + found_module <- tcPluginIO $ findPluginModule fc fopts units (Just home_unit) mod_nm case found_module of FoundModule h -> return (fr_mod h) _ -> do |