diff options
42 files changed, 672 insertions, 392 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index a3795eda79..4c8864014f 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -312,7 +312,7 @@ import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Iface.Load ( loadSysInterface ) import GHC.Tc.Types import GHC.Core.Predicate -import GHC.Unit.State +import GHC.Unit import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs @@ -342,7 +342,6 @@ import GHC.Driver.Ppr import GHC.SysTools import GHC.SysTools.BaseDir import GHC.Types.Annotations -import GHC.Unit.Module import GHC.Utils.Panic import GHC.Platform import GHC.Data.Bag ( listToBag ) @@ -1165,8 +1164,12 @@ getInsts = withSession $ \hsc_env -> return $ ic_instances (hsc_IC hsc_env) getPrintUnqual :: GhcMonad m => m PrintUnqualified -getPrintUnqual = withSession $ \hsc_env -> - return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) +getPrintUnqual = withSession $ \hsc_env -> do + let dflags = hsc_dflags hsc_env + return $ icPrintUnqual + (unitState dflags) + (mkHomeUnitFromFlags dflags) + (hsc_IC hsc_env) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { @@ -1261,7 +1264,11 @@ mkPrintUnqualifiedForModule :: GhcMonad m => ModuleInfo -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do - return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) + let dflags = hsc_dflags hsc_env + mk_print_unqual = mkPrintUnqualified + (unitState dflags) + (mkHomeUnitFromFlags dflags) + return (fmap mk_print_unqual (minf_rdr_env minf)) modInfoLookupName :: GhcMonad m => ModuleInfo -> Name @@ -1494,12 +1501,10 @@ showRichTokenStream ts = go startLoc ts "" -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do - let - dflags = hsc_dflags hsc_env - this_pkg = homeUnit dflags - -- + let dflags = hsc_dflags hsc_env + home_unit = mkHomeUnitFromFlags dflags case maybe_pkg of - Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m -> return m @@ -1511,7 +1516,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of - Found loc m | moduleUnit m /= this_pkg -> return m + Found loc m | not (isHomeModule home_unit m) -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError dflags noSrcSpan mod_name err diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index a9dc3ec4a5..1a308d11af 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -101,7 +101,10 @@ core2core hsc_env guts@(ModGuts { mg_module = mod dflags = hsc_dflags hsc_env home_pkg_rules = hptRules hsc_env (dep_mods deps) hpt_rule_base = mkRuleBase home_pkg_rules - print_unqual = mkPrintUnqualified dflags rdr_env + print_unqual = mkPrintUnqualified + (unitState dflags) + (mkHomeUnitFromFlags dflags) + rdr_env -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to -- consume the ModGuts to find the module) but somewhat ugly because mg_module may @@ -663,7 +666,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) } where dflags = hsc_dflags hsc_env - print_unqual = mkPrintUnqualified dflags rdr_env + print_unqual = mkPrintUnqualified (unitState dflags) (mkHomeUnitFromFlags dflags) rdr_env simpl_env = mkSimplEnv mode active_rule = activeRule mode active_unf = activeUnfolding mode diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 831517f21c..4ecb29da7a 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -48,7 +48,7 @@ import GHC.Types.Id.Info import GHC.Builtin.Types import GHC.Core.DataCon import GHC.Types.Basic -import GHC.Unit.Module +import GHC.Unit import GHC.Types.Unique.Supply import GHC.Data.Maybe import GHC.Data.OrdList @@ -1496,10 +1496,11 @@ mkConvertNumLiteral hsc_env = do let dflags = hsc_dflags hsc_env platform = targetPlatform dflags + home_unit = mkHomeUnitFromFlags dflags guardBignum act - | homeUnitId dflags == primUnitId + | isHomeUnitInstanceOf home_unit primUnitId = return $ panic "Bignum literals are not supported in ghc-prim" - | homeUnitId dflags == bignumUnitId + | isHomeUnitInstanceOf home_unit bignumUnitId = return $ panic "Bignum literals are not supported in ghc-bignum" | otherwise = act diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index c103955ab8..2523fb55d5 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -137,7 +137,7 @@ withBkpSession :: IndefUnitId -> BkpM a withBkpSession cid insts deps session_type do_this = do dflags <- getDynFlags - let cid_fs = unitIdFS (indefUnit cid) + let cid_fs = unitFS (indefUnit cid) is_primary = False uid_str = unpackFS (mkInstantiatedUnitHash cid insts) cid_str = unpackFS cid_fs @@ -172,12 +172,12 @@ withBkpSession cid insts deps session_type do_this = do backend = case session_type of TcSession -> NoBackend _ -> backend dflags, - homeUnitInstantiations = insts, + homeUnitInstantiations_ = insts, -- if we don't have any instantiation, don't -- fill `homeUnitInstanceOfId` as it makes no -- sense (we're not instantiating anything) - homeUnitInstanceOfId = if null insts then Nothing else Just cid, - homeUnitId = + homeUnitInstanceOf_ = if null insts then Nothing else Just (indefUnit cid), + homeUnitId_ = case session_type of TcSession -> newUnitId cid Nothing -- No hash passed if no instances @@ -286,7 +286,6 @@ buildUnit session cid insts lunit = do dflags <- getDynFlags mod_graph <- hsunitModuleGraph dflags (unLoc lunit) - -- pprTrace "mod_graph" (ppr mod_graph) $ return () msg <- mkBackpackMsg ok <- load' LoadAllTargets (Just msg) mod_graph @@ -310,6 +309,7 @@ buildUnit session cid insts lunit = do let compat_fs = unitIdFS (indefUnit cid) compat_pn = PackageName compat_fs + unit_id = homeUnitId (mkHomeUnitFromFlags (hsc_dflags hsc_env)) return GenericUnitInfo { -- Stub data @@ -317,7 +317,7 @@ buildUnit session cid insts lunit = do unitPackageId = PackageId compat_fs, unitPackageName = compat_pn, unitPackageVersion = makeVersion [], - unitId = toUnitId (homeUnit dflags), + unitId = unit_id, unitComponentName = Nothing, unitInstanceOf = cid, unitInstantiations = insts, @@ -562,7 +562,7 @@ type PackageNameMap a = Map PackageName a -- to use this for anything unitDefines :: UnitState -> LHsUnit PackageName -> (PackageName, HsComponentId) unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) - = (pn, HsComponentId pn (updateIndefUnitId pkgstate (Indefinite (UnitId fs) Nothing))) + = (pn, HsComponentId pn (mkIndefUnitId pkgstate (UnitId fs))) bkpPackageNameMap :: UnitState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units) @@ -642,6 +642,7 @@ hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph hsunitModuleGraph dflags unit = do let decls = hsunitBody unit pn = hsPackageName (unLoc (hsunitName unit)) + home_unit = mkHomeUnitFromFlags dflags -- 1. Create a HsSrcFile/HsigFile summary for every -- explicitly mentioned module/signature. @@ -655,7 +656,7 @@ hsunitModuleGraph dflags unit = do -- requirement. let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) | n <- nodes ] - req_nodes <- fmap catMaybes . forM (homeUnitInstantiations dflags) $ \(mod_name, _) -> + req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) -> let has_local = Map.member (mod_name, True) node_map in if has_local then return Nothing diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs index 22408ca149..0b9ad24371 100644 --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -76,10 +76,9 @@ flushFinderCaches :: HscEnv -> IO () flushFinderCaches hsc_env = atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) where - this_pkg = homeUnit (hsc_dflags hsc_env) - fc_ref = hsc_FC hsc_env - is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True - | otherwise = False + fc_ref = hsc_FC hsc_env + home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + is_ext mod _ = not (isHomeInstalledModule home_unit mod) addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () addToFinderCache ref key val = @@ -136,8 +135,8 @@ findPluginModule hsc_env mod_name = findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findExactModule hsc_env mod = - let dflags = hsc_dflags hsc_env - in if moduleUnit mod `unitIdEq` homeUnit dflags + let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + in if isHomeInstalledModule home_unit mod then findInstalledHomeModule hsc_env (moduleName mod) else findPackageModule hsc_env mod @@ -176,7 +175,8 @@ orIfNotFound this or_this = do -- was successful.) homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult homeSearchCache hsc_env mod_name do_this = do - let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + mod = mkHomeInstalledModule home_unit mod_name modLocationCache hsc_env mod do_this findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString @@ -248,21 +248,18 @@ modLocationCache hsc_env mod do_this = do addToFinderCache (hsc_FC hsc_env) mod result return result -mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule -mkHomeInstalledModule dflags mod_name = - let iuid = homeUnitId dflags - in Module iuid mod_name - -- This returns a module because it's more convenient for users addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module addHomeModuleToFinder hsc_env mod_name loc = do - let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + mod = mkHomeInstalledModule home_unit mod_name addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) - return (mkHomeModule (hsc_dflags hsc_env) mod_name) + return (mkHomeModule home_unit mod_name) uncacheModule :: HscEnv -> ModuleName -> IO () uncacheModule hsc_env mod_name = do - let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + mod = mkHomeInstalledModule home_unit mod_name removeFromFinderCache (hsc_FC hsc_env) mod -- ----------------------------------------------------------------------------- @@ -272,7 +269,7 @@ findHomeModule :: HscEnv -> ModuleName -> IO FindResult findHomeModule hsc_env mod_name = do r <- findInstalledHomeModule hsc_env mod_name return $ case r of - InstalledFound loc _ -> Found loc (mkModule uid mod_name) + InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name) InstalledNoPackage _ -> NoPackage uid -- impossible InstalledNotFound fps _ -> NotFound { fr_paths = fps, @@ -283,8 +280,9 @@ findHomeModule hsc_env mod_name = do fr_suggestions = [] } where - dflags = hsc_dflags hsc_env - uid = homeUnit dflags + dflags = hsc_dflags hsc_env + home_unit = mkHomeUnitFromFlags dflags + uid = homeUnitAsUnit (mkHomeUnitFromFlags dflags) -- | Implements the search for a module name in the home package only. Calling -- this function directly is usually *not* what you want; currently, it's used @@ -307,9 +305,10 @@ findInstalledHomeModule hsc_env mod_name = homeSearchCache hsc_env mod_name $ let dflags = hsc_dflags hsc_env + home_unit = mkHomeUnitFromFlags dflags home_path = importPaths dflags hisuf = hiSuf dflags - mod = mkHomeInstalledModule dflags mod_name + mod = mkHomeInstalledModule home_unit mod_name source_exts = [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") @@ -675,6 +674,7 @@ cantFindErr cannot_find _ dflags mod_name find_result $$ more_info where pkgs = unitState dflags + home_unit = mkHomeUnitFromFlags dflags more_info = case find_result of NoPackage pkg @@ -684,7 +684,7 @@ cantFindErr cannot_find _ dflags mod_name find_result NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest } - | Just pkg <- mb_pkg, pkg /= homeUnit dflags + | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg) -> not_found_in_package pkg files | not (null suggest) @@ -793,6 +793,10 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result = ptext cannot_find <+> quotes (ppr mod_name) $$ more_info where + home_unit = mkHomeUnitFromFlags dflags + unit_state = unitState dflags + build_tag = waysBuildTag (ways dflags) + more_info = case find_result of InstalledNoPackage pkg @@ -800,7 +804,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result text "was found" $$ looks_like_srcpkgid pkg InstalledNotFound files mb_pkg - | Just pkg <- mb_pkg, not (pkg `unitIdEq` homeUnit dflags) + | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg) -> not_found_in_package pkg files | null files @@ -811,14 +815,11 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result _ -> panic "cantFindInstalledErr" - build_tag = waysBuildTag (ways dflags) - pkgstate = unitState dflags - looks_like_srcpkgid :: UnitId -> SDoc looks_like_srcpkgid pk -- Unsafely coerce a unit id (i.e. an installed package component -- identifier) into a PackageId and see if it means anything. - | (pkg:pkgs) <- searchPackageId pkgstate (PackageId (unitIdFS pk)) + | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk)) = parens (text "This unit ID looks like the source package ID;" $$ text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ (if null pkgs then Outputable.empty diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 42e9a35724..ab27efc832 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -101,8 +101,7 @@ import GHC.Utils.Panic import GHC.Core.ConLike import GHC.Parser.Annotation -import GHC.Unit.Module -import GHC.Unit.State +import GHC.Unit import GHC.Types.Name.Reader import GHC.Hs import GHC.Hs.Dump @@ -194,7 +193,8 @@ import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do - eps_var <- newIORef (initExternalPackageState dflags) + let home_unit = mkHomeUnitFromFlags dflags + eps_var <- newIORef (initExternalPackageState home_unit) us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv @@ -469,14 +469,15 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do hsc_env <- getHscEnv let hsc_src = ms_hsc_src mod_summary dflags = hsc_dflags hsc_env + home_unit = mkHomeUnitFromFlags dflags outer_mod = ms_mod mod_summary mod_name = moduleName outer_mod - outer_mod' = mkHomeModule dflags mod_name - inner_mod = canonicalizeHomeModule dflags mod_name + outer_mod' = mkHomeModule home_unit mod_name + inner_mod = homeModuleNameInstantiation home_unit mod_name src_filename = ms_hspp_file mod_summary real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 keep_rn' = gopt Opt_WriteHie dflags || keep_rn - MASSERT( isHomeModule dflags outer_mod ) + MASSERT( isHomeModule home_unit outer_mod ) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc else @@ -1115,10 +1116,11 @@ hscCheckSafe' :: Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId) hscCheckSafe' m l = do dflags <- getDynFlags + let home_unit = mkHomeUnitFromFlags dflags (tw, pkgs) <- isModSafe m l case tw of - False -> return (Nothing, pkgs) - True | isHomeModule dflags m -> return (Nothing, pkgs) + False -> return (Nothing, pkgs) + True | isHomeModule home_unit m -> return (Nothing, pkgs) -- TODO: do we also have to check the trust of the instantiation? -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) @@ -1193,7 +1195,7 @@ hscCheckSafe' m l = do packageTrusted _ Sf_Safe False _ = True packageTrusted _ Sf_SafeInferred False _ = True packageTrusted dflags _ _ m - | isHomeModule dflags m = True + | isHomeModule (mkHomeUnitFromFlags dflags) m = True | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface) @@ -1486,14 +1488,15 @@ hscInteractive hsc_env cgguts location = do hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do - let dflags = hsc_dflags hsc_env + let dflags = hsc_dflags hsc_env + home_unit = mkHomeUnitFromFlags dflags cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename - cmm_mod = mkHomeModule dflags mod_name + cmm_mod = mkHomeModule home_unit mod_name -- Compile decls in Cmm files one decl at a time, to avoid re-ordering -- them in SRT analysis. diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 74c3f9efa8..9e7870c638 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -46,7 +46,7 @@ import GHC.Driver.Finder import GHC.Driver.Monad import GHC.Parser.Header import GHC.Driver.Types -import GHC.Unit.Module +import GHC.Unit import GHC.IfaceToCore ( typecheckIface ) import GHC.Tc.Utils.Monad ( initIfaceCheck ) import GHC.Driver.Main @@ -66,7 +66,6 @@ import GHC.Data.StringBuffer import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Tc.Utils.Backpack -import GHC.Unit.State import GHC.Types.Unique.Set import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt @@ -655,10 +654,10 @@ discardIC hsc_env old_ic = hsc_IC hsc_env empty_ic = emptyInteractiveContext dflags keep_external_name ic_name - | nameIsFromExternalPackage this_pkg old_name = old_name + | nameIsFromExternalPackage home_unit old_name = old_name | otherwise = ic_name empty_ic where - this_pkg = homeUnit dflags + home_unit = mkHomeUnitFromFlags dflags old_name = ic_name old_ic -- | If there is no -o option, guess the name of target executable @@ -1202,13 +1201,14 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup let home_imps = map unLoc $ ms_home_imps mod let home_src_imps = map unLoc $ ms_home_srcimps mod + let home_unit = mkHomeUnitFromFlags lcl_dflags -- All the textual imports of this module. let textual_deps = Set.fromList $ zipWith f home_imps (repeat NotBoot) ++ zipWith f home_src_imps (repeat IsBoot) where f mn isBoot = GWIB - { gwib_mod = mkHomeModule lcl_dflags mn + { gwib_mod = mkHomeModule home_unit mn , gwib_isBoot = isBoot } @@ -2210,7 +2210,7 @@ enableCodeGenForTH = backend dflags == NoBackend && -- Don't enable codegen for TH on indefinite packages; we -- can't compile anything anyway! See #16219. - homeUnitIsDefinite dflags + isHomeUnitDefinite (mkHomeUnitFromFlags dflags) -- | Update the every ModSummary that is depended on -- by a module that needs unboxed tuples. We enable codegen to @@ -2499,6 +2499,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | otherwise = find_it where dflags = hsc_dflags hsc_env + home_unit = mkHomeUnitFromFlags dflags check_timestamp old_summary location src_fn = checkSummaryTimestamp @@ -2557,12 +2558,12 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations dflags))) $ + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $ let suggested_instantiated_with = hcat (punctuate comma $ [ ppr k <> text "=" <> ppr v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) - : homeUnitInstantiations dflags) + : homeUnitInstantiations home_unit) ]) in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index f87fd1380d..ca82e216d9 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -40,7 +40,7 @@ module GHC.Driver.Pipeline ( import GHC.Prelude import GHC.Driver.Pipeline.Monad -import GHC.Unit.State +import GHC.Unit import GHC.Platform.Ways import GHC.Platform.ArchOS import GHC.Parser.Header @@ -51,7 +51,6 @@ import GHC.Driver.Main import GHC.Driver.Finder import GHC.Driver.Types hiding ( Hsc ) import GHC.Utils.Outputable -import GHC.Unit.Module import GHC.Utils.Error import GHC.Driver.Session import GHC.Driver.Backend @@ -382,7 +381,8 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- https://gitlab.haskell.org/ghc/ghc/issues/12673 -- and https://github.com/haskell/cabal/issues/2257 empty_stub <- newTempName dflags TFL_CurrentModule "c" - let src = text "int" <+> ppr (mkHomeModule dflags mod_name) <+> text "= 0;" + let home_unit = mkHomeUnitFromFlags dflags + src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) _ <- runPipeline StopLn hsc_env (empty_stub, Nothing, Nothing) @@ -516,9 +516,9 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line. - let pkgstate = unitState dflags - let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib) - | Just c <- map (lookupUnitId pkgstate) pkg_deps, + let unit_state = unitState dflags + let pkg_hslibs = [ (collectLibraryPaths (ways dflags) [c], lib) + | Just c <- map (lookupUnitId unit_state) pkg_deps, lib <- packageHsLibs dflags c ] pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs @@ -1227,6 +1227,7 @@ runPhase (RealPhase cc_phase) input_fn dflags = do let platform = targetPlatform dflags hcc = cc_phase `eqPhase` HCc + home_unit = mkHomeUnitFromFlags dflags let cmdline_include_paths = includePaths dflags @@ -1236,7 +1237,11 @@ runPhase (RealPhase cc_phase) input_fn dflags -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) - pkg_include_dirs <- liftIO $ getUnitIncludePath dflags pkgs + pkg_include_dirs <- liftIO $ getUnitIncludePath + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + pkgs let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] @@ -1264,11 +1269,19 @@ runPhase (RealPhase cc_phase) input_fn dflags pkg_extra_cc_opts <- liftIO $ if hcc then return [] - else getUnitExtraCcOpts dflags pkgs + else getUnitExtraCcOpts + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + pkgs framework_paths <- if platformUsesFrameworks platform - then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath dflags pkgs + then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + pkgs let cmdlineFrameworkPaths = frameworkPaths dflags return $ map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths) @@ -1315,7 +1328,7 @@ runPhase (RealPhase cc_phase) input_fn dflags -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (if platformOS platform == OSMinGW32 && - homeUnitId dflags == baseUnitId + isHomeUnitId home_unit baseUnitId then [ "-DCOMPILING_BASE_PACKAGE" ] else []) @@ -1671,7 +1684,12 @@ linkBinary' staticLink dflags o_files dep_units = do then return output_fn else do d <- getCurrentDirectory return $ normalise (d </> output_fn) - pkg_lib_paths <- getUnitLibraryPath dflags dep_units + pkg_lib_paths <- getUnitLibraryPath + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + (ways dflags) + dep_units let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l | osElfTarget (platformOS platform) && @@ -1940,7 +1958,11 @@ linkStaticLib dflags o_files dep_units = do output_exists <- doesFileExist full_output_fn (when output_exists) $ removeFile full_output_fn - pkg_cfgs_init <- getPreloadUnitsAnd dflags dep_units + pkg_cfgs_init <- getPreloadUnitsAnd + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + dep_units let pkg_cfgs | gopt Opt_LinkRts dflags @@ -1969,7 +1991,11 @@ doCpp dflags raw input_fn output_fn = do let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags - pkg_include_dirs <- getUnitIncludePath dflags [] + pkg_include_dirs <- getUnitIncludePath + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + [] let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] @@ -2235,7 +2261,11 @@ getGhcVersionPathName dflags = do candidates <- case ghcVersionFile dflags of Just path -> return [path] Nothing -> (map (</> "ghcversion.h")) <$> - (getUnitIncludePath dflags [rtsUnitId]) + (getUnitIncludePath + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + [rtsUnitId]) found <- filterM doesFileExist candidates case found of diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 5ec163c54a..45f6d4328d 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -65,7 +65,7 @@ module GHC.Driver.Session ( addWay', targetProfile, - homeUnit, mkHomeModule, isHomeModule, + mkHomeUnitFromFlags, -- ** Log output putLogMsg, @@ -168,8 +168,6 @@ module GHC.Driver.Session ( updOptLevel, setTmpDir, setUnitId, - canonicalizeHomeModule, - canonicalizeModuleIfHome, TurnOnFlag, turnOn, @@ -241,6 +239,7 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile import GHC.UniqueSubdir (uniqueSubdir) +import GHC.Unit.Home import GHC.Unit.Types import GHC.Unit.Parser import GHC.Unit.Module @@ -248,7 +247,7 @@ import GHC.Driver.Ppr import {-# SOURCE #-} GHC.Driver.Plugins import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Builtin.Names ( mAIN ) -import {-# SOURCE #-} GHC.Unit.State (UnitState, emptyUnitState, UnitDatabase, updateIndefUnitId) +import {-# SOURCE #-} GHC.Unit.State (UnitState, emptyUnitState, UnitDatabase) import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags import GHC.Driver.Backend @@ -530,9 +529,9 @@ data DynFlags = DynFlags { solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver -- Typically only 1 is needed - homeUnitId :: UnitId, -- ^ Target home unit-id - homeUnitInstanceOfId :: Maybe IndefUnitId, -- ^ Unit-id to instantiate - homeUnitInstantiations:: [(ModuleName, Module)], -- ^ How to instantiate `homeUnitInstanceOfId` unit + homeUnitId_ :: UnitId, -- ^ Target home unit-id + homeUnitInstanceOf_ :: Maybe UnitId, -- ^ Id of the unit to instantiate + homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations -- ways ways :: Ways, -- ^ Way flags from the command line @@ -1273,9 +1272,9 @@ defaultDynFlags mySettings llvmConfig = reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, - homeUnitId = mainUnitId, - homeUnitInstanceOfId = Nothing, - homeUnitInstantiations = [], + homeUnitId_ = mainUnitId, + homeUnitInstanceOf_ = Nothing, + homeUnitInstantiations_ = [], objectDir = Nothing, dylibInstallName = Nothing, @@ -1908,31 +1907,27 @@ setOutputHi f d = d { outputHi = f} setJsonLogAction :: DynFlags -> DynFlags setJsonLogAction d = d { log_action = jsonLogAction } --- | Make a module in home unit -mkHomeModule :: DynFlags -> ModuleName -> Module -mkHomeModule dflags = mkModule (homeUnit dflags) - --- | Test if the module comes from the home unit -isHomeModule :: DynFlags -> Module -> Bool -isHomeModule dflags m = moduleUnit m == homeUnit dflags - -- | Get home unit -homeUnit :: DynFlags -> Unit -homeUnit dflags = - case (homeUnitInstanceOfId dflags, homeUnitInstantiations dflags) of - (Nothing,[]) -> RealUnit (Definite (homeUnitId dflags)) +mkHomeUnitFromFlags :: DynFlags -> HomeUnit +mkHomeUnitFromFlags dflags = + let !hu_id = homeUnitId_ dflags + !hu_instanceof = homeUnitInstanceOf_ dflags + !hu_instantiations = homeUnitInstantiations_ dflags + in case (hu_instanceof, hu_instantiations) of + (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with") (Just u, is) -- detect fully indefinite units: all their instantiations are hole -- modules and the home unit id is the same as the instantiating unit -- id (see Note [About units] in GHC.Unit) - | all (isHoleModule . snd) is && indefUnit u == homeUnitId dflags - -> mkVirtUnit (updateIndefUnitId (unitState dflags) u) is - -- otherwise it must be that we compile a fully definite units + | all (isHoleModule . snd) is && u == hu_id + -> IndefiniteHomeUnit u is + -- otherwise it must be that we (fully) instantiate an indefinite unit + -- to make it definite. -- TODO: error when the unit is partially instantiated?? | otherwise - -> RealUnit (Definite (homeUnitId dflags)) + -> DefiniteHomeUnit hu_id (Just (u, is)) parseUnitInsts :: String -> Instantiations parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of @@ -1947,11 +1942,11 @@ parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of setUnitInstantiations :: String -> DynFlags -> DynFlags setUnitInstantiations s d = - d { homeUnitInstantiations = parseUnitInsts s } + d { homeUnitInstantiations_ = parseUnitInsts s } setUnitInstanceOf :: String -> DynFlags -> DynFlags setUnitInstanceOf s d = - d { homeUnitInstanceOfId = Just (Indefinite (UnitId (fsLit s)) Nothing) } + d { homeUnitInstanceOf_ = Just (UnitId (fsLit s)) } addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } @@ -4533,22 +4528,7 @@ parseUnitArg = fmap UnitIdArg parseUnit setUnitId :: String -> DynFlags -> DynFlags -setUnitId p d = d { homeUnitId = stringToUnitId p } - --- | Given a 'ModuleName' of a signature in the home library, find --- out how it is instantiated. E.g., the canonical form of --- A in @p[A=q[]:A]@ is @q[]:A@. -canonicalizeHomeModule :: DynFlags -> ModuleName -> Module -canonicalizeHomeModule dflags mod_name = - case lookup mod_name (homeUnitInstantiations dflags) of - Nothing -> mkHomeModule dflags mod_name - Just mod -> mod - -canonicalizeModuleIfHome :: DynFlags -> Module -> Module -canonicalizeModuleIfHome dflags mod - = if homeUnit dflags == moduleUnit mod - then canonicalizeHomeModule dflags (moduleName mod) - else mod +setUnitId p d = d { homeUnitId_ = stringToUnitId p } -- If we're linking a binary, then only backends that produce object -- code are allowed (requests for other target types are ignored). diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index e6cc556121..502ec07569 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -80,7 +80,7 @@ module GHC.Driver.Types ( extendInteractiveContext, extendInteractiveContextWithIds, substInteractiveContext, setInteractivePrintName, icInteractiveModule, - InteractiveImport(..), setInteractivePackage, + InteractiveImport(..), mkPrintUnqualified, pprModulePrefix, mkQualPackage, mkQualModule, pkgQual, @@ -1797,9 +1797,9 @@ icInScopeTTs :: InteractiveContext -> [TyThing] icInScopeTTs = ic_tythings -- | Get the PrintUnqualified function based on the flags and this InteractiveContext -icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified -icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = - mkPrintUnqualified dflags grenv +icPrintUnqual :: UnitState -> HomeUnit -> InteractiveContext -> PrintUnqualified +icPrintUnqual unit_state home_unit InteractiveContext{ ic_rn_gbl_env = grenv } = + mkPrintUnqualified unit_state home_unit grenv -- | extendInteractiveContext is called with new TyThings recently defined to update the -- InteractiveContext to include them. Ids are easily removed when shadowed, @@ -1852,12 +1852,6 @@ shadowed_by ids = shadowed shadowed id = getOccName id `elemOccSet` new_occs new_occs = mkOccSet (map getOccName ids) --- | Set the 'DynFlags.homeUnitId' to 'interactive' -setInteractivePackage :: HscEnv -> HscEnv -setInteractivePackage hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) - { homeUnitId = interactiveUnitId } } - setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} @@ -1956,12 +1950,12 @@ with some holes, we should try to give the user some more useful information. -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. -mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified dflags env = QueryQualify qual_name - (mkQualModule dflags) - (mkQualPackage pkgs) +mkPrintUnqualified :: UnitState -> HomeUnit -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified unit_state home_unit env + = QueryQualify qual_name + (mkQualModule unit_state home_unit) + (mkQualPackage unit_state) where - pkgs = unitState dflags qual_name mod occ | [gre] <- unqual_gres , right_name gre @@ -2016,9 +2010,9 @@ mkPrintUnqualified dflags env = QueryQualify qual_name -- | Creates a function for formatting modules based on two heuristics: -- (1) if the module is the current module, don't qualify, and (2) if there -- is only one exposed package which exports this module, don't qualify. -mkQualModule :: DynFlags -> QueryQualifyModule -mkQualModule dflags mod - | isHomeModule dflags mod = False +mkQualModule :: UnitState -> HomeUnit -> QueryQualifyModule +mkQualModule unit_state home_unit mod + | isHomeModule home_unit mod = False | [(_, pkgconfig)] <- lookup, mkUnit pkgconfig == moduleUnit mod @@ -2027,7 +2021,7 @@ mkQualModule dflags mod = False | otherwise = True - where lookup = lookupModuleInAllUnits (unitState dflags) (moduleName mod) + where lookup = lookupModuleInAllUnits unit_state (moduleName mod) -- | Creates a function for formatting packages based on two heuristics: -- (1) don't qualify if the package in question is "main", and (2) only qualify @@ -2308,7 +2302,7 @@ lookupType dflags hpt pte name where mod = ASSERT2( isExternalName name, ppr name ) if isHoleName name - then mkHomeModule dflags (moduleName (nameModule name)) + then mkHomeModule (mkHomeUnitFromFlags dflags) (moduleName (nameModule name)) else nameModule name -- | As 'lookupType', but with a marginally easier-to-use interface diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 3d96b38ccc..2b98d9343f 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -50,7 +50,7 @@ import GHC.Core.Coercion import GHC.Builtin.Types import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make -import GHC.Unit.Module +import GHC.Unit import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Core.Rules @@ -119,7 +119,11 @@ deSugar hsc_env }) = do { let dflags = hsc_dflags hsc_env - print_unqual = mkPrintUnqualified dflags rdr_env + home_unit = mkHomeUnitFromFlags dflags + print_unqual = mkPrintUnqualified + (unitState dflags) + home_unit + rdr_env ; withTiming dflags (text "Desugar"<+>brackets (ppr mod)) (const ()) $ @@ -174,9 +178,9 @@ deSugar hsc_env ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps ; let used_names = mkUsedNames tcg_env - pluginModules = - map lpModule (cachedPlugins (hsc_dflags hsc_env)) - ; deps <- mkDependencies (homeUnitId (hsc_dflags hsc_env)) + pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env)) + home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + ; deps <- mkDependencies (homeUnitId home_unit) (map mi_module pluginModules) tcg_env ; used_th <- readIORef tc_splice_used diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 43b4376752..b6b0305a25 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -294,7 +294,10 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var gbl_env = DsGblEnv { ds_mod = mod , ds_fam_inst_env = fam_inst_env , ds_if_env = (if_genv, if_lenv) - , ds_unqual = mkPrintUnqualified dflags rdr_env + , ds_unqual = mkPrintUnqualified + (unitState dflags) + (mkHomeUnitFromFlags dflags) + rdr_env , ds_msgs = msg_var , ds_complete_matches = completeMatchMap , ds_cc_st = cc_st_var diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index ef42890302..7fe799ebe4 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -60,7 +60,7 @@ its dep_orphs. This was the cause of #14128. -- | Extract information from the rename and typecheck phases to produce -- a dependencies information for the module being compiled. -- --- The first argument is additional dependencies from plugins +-- The second argument is additional dependencies from plugins mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies mkDependencies iuid pluginModules (TcGblEnv{ tcg_mod = mod, @@ -174,7 +174,7 @@ mkPluginUsage hsc_env pluginModule LookupFound _ pkg -> do -- The plugin is from an external package: -- search for the library files containing the plugin. - let searchPaths = collectLibraryPaths dflags [pkg] + let searchPaths = collectLibraryPaths (ways dflags) [pkg] useDyn = WayDyn `elem` ways dflags suffix = if useDyn then soExt platform else "a" libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix @@ -252,7 +252,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names where hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env - this_pkg = homeUnit dflags + home_unit = mkHomeUnitFromFlags dflags used_mods = moduleEnvKeys ent_map dir_imp_mods = moduleEnvKeys direct_imports @@ -278,7 +278,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names Just mod -> -- See Note [Identity versus semantic module] let mod' = if isHoleModule mod - then mkModule this_pkg (moduleName mod) + then mkHomeModule home_unit (moduleName mod) else mod -- This lambda function is really just a -- specialised (++); originally came about to @@ -298,7 +298,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names -- things in *this* module = Nothing - | moduleUnit mod /= this_pkg + | not (isHomeModule home_unit mod) = Just UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index b7ed66734e..508a6b8281 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -82,6 +82,7 @@ import GHC.Types.FieldLabel import GHC.Iface.Rename import GHC.Types.Unique.DSet import GHC.Driver.Plugins +import GHC.Unit.Home import Control.Monad import Control.Exception @@ -402,8 +403,9 @@ loadInterface doc_str mod from | isHoleModule mod -- Hole modules get special treatment = do dflags <- getDynFlags + let home_unit = mkHomeUnitFromFlags dflags -- Redo search for our local hole module - loadInterface doc_str (mkHomeModule dflags (moduleName mod)) from + loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from | otherwise = withTimingSilentD (text "loading interface") (pure ()) $ do { -- Read the state @@ -414,6 +416,7 @@ loadInterface doc_str mod from -- Check whether we have the interface already ; dflags <- getDynFlags + ; let home_unit = mkHomeUnitFromFlags dflags ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded @@ -423,7 +426,7 @@ loadInterface doc_str mod from _ -> do { -- READ THE MODULE IN - ; read_result <- case (wantHiBootFile dflags eps mod from) of + ; read_result <- case (wantHiBootFile home_unit eps mod from) of Failed err -> return (Failed err) Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod ; case read_result of { @@ -494,7 +497,7 @@ loadInterface doc_str mod from ; WARN( bad_boot, ppr mod ) updateEps_ $ \ eps -> - if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface + if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface then eps else if bad_boot -- See Note [Loading your own hi-boot file] @@ -616,12 +619,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 :: DynFlags -> ModIface -> Bool -is_external_sig dflags iface = +is_external_sig :: HomeUnit -> ModIface -> Bool +is_external_sig home_unit iface = -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package - moduleUnit (mi_module iface) /= homeUnit dflags + not (isHomeModule home_unit (mi_module iface)) -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only @@ -643,8 +646,9 @@ computeInterface :: computeInterface doc_str hi_boot_file mod0 = do MASSERT( not (isHoleModule mod0) ) dflags <- getDynFlags + let home_unit = mkHomeUnitFromFlags dflags case getModuleInstantiation mod0 of - (imod, Just indef) | homeUnitIsIndefinite dflags -> do + (imod, Just indef) | isHomeUnitIndefinite home_unit -> do r <- findAndReadIface doc_str imod mod0 hi_boot_file case r of Succeeded (iface0, path) -> do @@ -702,13 +706,13 @@ moduleFreeHolesPrecise doc_str mod return (Succeeded (renameFreeHoles ifhs insts)) Failed err -> return (Failed err) -wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom +wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr MsgDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot -wantHiBootFile dflags eps mod from +wantHiBootFile home_unit eps mod from = case from of ImportByUser usr_boot - | usr_boot == IsBoot && not this_package + | usr_boot == IsBoot && notHomeModule home_unit mod -> Failed (badSourceImport mod) | otherwise -> Succeeded usr_boot @@ -716,10 +720,12 @@ wantHiBootFile dflags eps mod from -> Succeeded NotBoot ImportBySystem - | not this_package -- If the module to be imported is not from this package - -> Succeeded NotBoot -- don't look it up in eps_is_boot, because that is keyed - -- on the ModuleName of *home-package* modules only. - -- We never import boot modules from other packages! + | notHomeModule home_unit mod + -> Succeeded NotBoot + -- If the module to be imported is not from this package + -- don't look it up in eps_is_boot, because that is keyed + -- on the ModuleName of *home-package* modules only. + -- We never import boot modules from other packages! | otherwise -> case lookupUFM (eps_is_boot eps) (moduleName mod) of @@ -729,8 +735,6 @@ wantHiBootFile dflags eps mod from Succeeded NotBoot -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules - where - this_package = homeUnit dflags == moduleUnit mod badSourceImport :: Module -> SDoc badSourceImport mod @@ -922,6 +926,7 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file -- Look for the file hsc_env <- getTopEnv mb_found <- liftIO (findExactModule hsc_env mod) + let home_unit = mkHomeUnitFromFlags dflags case mb_found of InstalledFound loc mod -> do -- Found file, so read it @@ -929,7 +934,7 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file (ml_hi_file loc) -- See Note [Home module load error] - if moduleUnit mod `unitIdEq` homeUnit dflags && + if isHomeInstalledModule home_unit mod && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do r <- read_file file_path @@ -1020,8 +1025,8 @@ readIface wanted_mod file_path ********************************************************* -} -initExternalPackageState :: DynFlags -> ExternalPackageState -initExternalPackageState dflags +initExternalPackageState :: HomeUnit -> ExternalPackageState +initExternalPackageState home_unit = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, @@ -1041,9 +1046,9 @@ initExternalPackageState dflags } where enableBignumRules - | homeUnitId dflags == primUnitId = EnableBignumRules False - | homeUnitId dflags == bignumUnitId = EnableBignumRules False - | otherwise = EnableBignumRules True + | isHomeUnitInstanceOf home_unit primUnitId = EnableBignumRules False + | isHomeUnitInstanceOf home_unit bignumUnitId = EnableBignumRules False + | otherwise = EnableBignumRules True builtinRules' = builtinRules enableBignumRules {- diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 3c33c0a3b6..575ef06a11 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -57,7 +57,7 @@ import GHC.Types.Avail import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set -import GHC.Unit.Module +import GHC.Unit import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic @@ -168,10 +168,9 @@ mkIfaceTc hsc_env safe_mode mod_details } = do let used_names = mkUsedNames tc_result - let pluginModules = - map lpModule (cachedPlugins (hsc_dflags hsc_env)) - deps <- mkDependencies - (homeUnitId (hsc_dflags hsc_env)) + let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env)) + let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + deps <- mkDependencies (homeUnitId home_unit) (map mi_module pluginModules) tc_result let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used @@ -226,7 +225,8 @@ mkIface_ hsc_env -- to expose in the interface = do - let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) + let home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod) entities = typeEnvElts type_env show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env) decls = [ tyThingToIfaceDecl show_linear_types entity diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 7c8dc9722c..2ffb094b11 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -44,6 +44,7 @@ import GHC.Utils.Fingerprint import GHC.Utils.Exception import GHC.Types.Unique.Set import GHC.Unit.State +import GHC.Unit.Home import Control.Monad import Data.Function @@ -215,7 +216,7 @@ checkVersions hsc_env mod_summary iface -- readIface will have verified that the UnitId matches, -- but we ALSO must make sure the instantiation matches up. See -- test case bkpcabal04! - ; if moduleUnit (mi_module iface) /= homeUnit (hsc_dflags hsc_env) + ; if not (isHomeModule home_unit (mi_module iface)) then return (RecompBecause "-this-unit-id changed", Nothing) else do { ; recomp <- checkFlagHash hsc_env iface ; if recompileRequired recomp then return (recomp, Nothing) else do { @@ -249,11 +250,12 @@ checkVersions hsc_env mod_summary iface -- all the dependent modules should be in the HPT already, so it's -- quite redundant ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } - ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] + ; recomp <- checkList [checkModUsage (homeUnitAsUnit home_unit) u + | u <- mi_usages iface] ; return (recomp, Just iface) }}}}}}}}}} where - this_pkg = homeUnit (hsc_dflags hsc_env) + home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) -- This is a bit of a hack really mod_deps :: ModuleNameEnv ModuleNameWithIsBoot mod_deps = mkModDeps (dep_mods (mi_deps iface)) @@ -333,9 +335,10 @@ pluginRecompileToRecompileRequired old_fp new_fp pr checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired checkHsig mod_summary iface = do dflags <- getDynFlags - let outer_mod = ms_mod mod_summary - inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) - MASSERT( moduleUnit outer_mod == homeUnit dflags ) + let home_unit = mkHomeUnitFromFlags dflags + outer_mod = ms_mod mod_summary + inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod) + MASSERT( isHomeModule home_unit outer_mod ) case inner_mod == mi_semantic_module iface of True -> up_to_date (text "implementing module unchanged") False -> return (RecompBecause "implementing module changed") @@ -449,15 +452,14 @@ checkDependencies hsc_env summary iface prev_dep_mods = dep_mods (mi_deps iface) prev_dep_plgn = dep_plgins (mi_deps iface) prev_dep_pkgs = dep_pkgs (mi_deps iface) - - this_pkg = homeUnit (hsc_dflags hsc_env) + home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) dep_missing (mb_pkg, L _ mod) = do find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg) let reason = moduleNameString mod ++ " changed" case find_res of Found _ mod - | pkg == this_pkg + | isHomeUnit home_unit pkg -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> @@ -483,7 +485,8 @@ checkDependencies hsc_env summary iface isOldHomeDeps = flip Set.member old_deps checkForNewHomeDependency (L _ mname) = do let - mod = mkModule this_pkg mname + home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) + mod = mkHomeModule home_unit mname str_mname = moduleNameString mname reason = str_mname ++ " changed" -- We only want to look at home modules to check if any new home dependency @@ -1351,11 +1354,12 @@ mkHashFun -> (Name -> IO Fingerprint) mkHashFun hsc_env eps name | isHoleModule orig_mod - = lookup (mkHomeModule dflags (moduleName orig_mod)) + = lookup (mkHomeModule home_unit (moduleName orig_mod)) | otherwise = lookup orig_mod where dflags = hsc_dflags hsc_env + home_unit = mkHomeUnitFromFlags dflags hpt = hsc_HPT hsc_env pit = eps_PIT eps occ = nameOccName name diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs index 391aaf2c86..3cbfdd1e3b 100644 --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -36,7 +36,7 @@ fingerprintDynFlags :: DynFlags -> Module fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing -- see #5878 - -- pkgopts = (homeUnit dflags, sort $ packageFlags dflags) + -- pkgopts = (homeUnit home_unit, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell -- oflags = sort $ filter filterOFlags $ flags dflags diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index ed8ac78761..376eee8350 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -299,6 +299,7 @@ rnIfaceGlobal :: Name -> ShIfM Name rnIfaceGlobal n = do hsc_env <- getTopEnv let dflags = hsc_dflags hsc_env + home_unit = mkHomeUnitFromFlags dflags iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv mb_nsubst <- fmap sh_if_shape getGblEnv hmap <- getHoleSubst @@ -342,7 +343,7 @@ rnIfaceGlobal n = do -- went from <A> to <B>. let m'' = if isHoleModule m' -- Pull out the local guy!! - then mkHomeModule dflags (moduleName m') + then mkHomeModule home_unit (moduleName m') else m' iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env $ loadSysInterface (text "rnIfaceGlobal") m'' diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index f687f2951b..557c3e0922 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -368,7 +368,10 @@ tidyProgram hsc_env (ModGuts { mg_module = mod (const ()) $ do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags - ; print_unqual = mkPrintUnqualified dflags rdr_env + ; print_unqual = mkPrintUnqualified + (unitState dflags) + (mkHomeUnitFromFlags dflags) + rdr_env ; implicit_binds = concatMap getImplicitBinds tcs } diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index dafc1e0fb0..1a131fc321 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -2213,7 +2213,8 @@ warnopt f options = f `EnumSet.member` pWarningFlags options -- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this. data ParserFlags = ParserFlags { pWarningFlags :: EnumSet WarningFlag - , pHomeUnitId :: UnitId -- ^ unit currently being compiled + , pHomeUnitId :: UnitId -- ^ id of the unit currently being compiled + -- (only used in Cmm parser) , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions } @@ -2644,6 +2645,7 @@ mkParserFlags' :: EnumSet WarningFlag -- ^ warnings flags enabled -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled -> UnitId -- ^ id of the unit currently being compiled + -- (used in Cmm parser) -> Bool -- ^ are safe imports on? -> Bool -- ^ keeping Haddock comment tokens -> Bool -- ^ keep regular comment tokens @@ -2725,7 +2727,7 @@ mkParserFlags = mkParserFlags' <$> DynFlags.warningFlags <*> DynFlags.extensionFlags - <*> DynFlags.homeUnitId + <*> DynFlags.homeUnitId_ <*> safeImportsOn <*> gopt Opt_Haddock <*> gopt Opt_KeepRawTokenStream diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 8920027e66..581af6e2d4 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -43,7 +43,7 @@ import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad import GHC.Types.ForeignCall ( CCallTarget(..) ) -import GHC.Unit.Module +import GHC.Unit import GHC.Driver.Types ( Warnings(..), plusWarns ) import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName , monadClassName, returnMName, thenMName @@ -375,8 +375,8 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty -- Mark any PackageTarget style imports as coming from the current package - ; let unitId = homeUnit $ hsc_dflags topEnv - spec' = patchForeignImport unitId spec + ; let home_unit = mkHomeUnitFromFlags (hsc_dflags topEnv) + spec' = patchForeignImport (homeUnitAsUnit home_unit) spec ; return (ForeignImport { fd_i_ext = noExtField , fd_name = name', fd_sig_ty = ty' diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 391c464fdb..7531913a7b 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -45,7 +45,7 @@ import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) import GHC.Iface.Load ( loadSrcInterface ) import GHC.Tc.Utils.Monad import GHC.Builtin.Names -import GHC.Unit.Module +import GHC.Unit import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -451,8 +451,10 @@ calculateAvails dflags iface mod_safe' want_boot imported_by = -- to be trusted? See Note [Trust Own Package] ptrust = trust == Sf_Trustworthy || trust_pkg + home_unit = mkHomeUnitFromFlags dflags + (dependent_mods, dependent_pkgs, pkg_trust_req) - | pkg == homeUnit dflags = + | isHomeUnit home_unit pkg = -- Imported module is from the home package -- Take its dependent modules and add imp_mod itself -- Take its dependent packages unchanged diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 2ee3143f76..7197710cfb 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -85,7 +85,7 @@ import GHC.LanguageExtensions import GHC.Types.Unique import GHC.Types.Unique.Supply import GHC.Utils.Monad -import GHC.Unit.Module +import GHC.Unit import GHC.Builtin.Names ( toDynName, pretendNameIsInScope ) import GHC.Builtin.Types ( isCTupleTyConName ) import GHC.Utils.Panic @@ -812,7 +812,7 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } -> -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> - if not (isHomeModule (hsc_dflags h) modl) + if notHomeModule (mkHomeUnitFromFlags (hsc_dflags h)) modl then return False else case lookupHpt (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details))) diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index 8c05c38c6c..4a3b03e5eb 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -47,6 +47,7 @@ import GHC.Platform.Ways import GHC.Types.Name import GHC.Types.Name.Env import GHC.Unit.Module +import GHC.Unit.Home import GHC.Data.List.SetOps import GHC.Runtime.Linker.Types (DynLinker(..), PersistentLinkerState(..)) import GHC.Driver.Session @@ -656,7 +657,6 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods ; return (lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env - this_pkg = homeUnit dflags -- The ModIface contains the transitive closure of the module dependencies -- within the current package, *except* for boot modules: if we encounter @@ -682,6 +682,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods let pkg = moduleUnit mod deps = mi_deps iface + home_unit = mkHomeUnitFromFlags dflags pkg_deps = dep_pkgs deps (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $ @@ -694,9 +695,9 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps -- - if pkg /= this_pkg + if not (isHomeUnit home_unit pkg) then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) - else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) + else follow_deps (map (mkHomeModule home_unit) boot_deps' ++ mods) acc_mods' acc_pkgs' where msg = text "need to link module" <+> ppr mod <+> diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs index e309b839f7..f3b4f4cc87 100644 --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -45,6 +45,7 @@ import GHC.Settings.Utils import GHC.Unit import GHC.Utils.Error import GHC.Utils.Panic +import GHC.Utils.Outputable import GHC.Platform import GHC.Driver.Session import GHC.Platform.Ways @@ -246,9 +247,13 @@ linkDynLib dflags0 o_files dep_packages verbFlags = getVerbFlags dflags o_file = outputFile dflags - pkgs <- getPreloadUnitsAnd dflags dep_packages + pkgs <- getPreloadUnitsAnd + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + dep_packages - let pkg_lib_paths = collectLibraryPaths dflags pkgs + let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l | ( osElfTarget (platformOS (targetPlatform dflags)) || @@ -426,11 +431,19 @@ getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String] getUnitFrameworkOpts dflags platform dep_packages | platformUsesFrameworks platform = do pkg_framework_path_opts <- do - pkg_framework_paths <- getUnitFrameworkPath dflags dep_packages + pkg_framework_paths <- getUnitFrameworkPath + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + dep_packages return $ map ("-F" ++) pkg_framework_paths pkg_framework_opts <- do - pkg_frameworks <- getUnitFrameworks dflags dep_packages + pkg_frameworks <- getUnitFrameworks + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + dep_packages return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] return (pkg_framework_path_opts ++ pkg_framework_opts) diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs index c4247d8496..94443824e3 100644 --- a/compiler/GHC/SysTools/ExtraObj.hs +++ b/compiler/GHC/SysTools/ExtraObj.hs @@ -172,8 +172,11 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do getLinkInfo :: DynFlags -> [UnitId] -> IO String getLinkInfo dflags dep_packages = do package_link_opts <- getUnitLinkOpts dflags dep_packages + let unit_state = unitState dflags + home_unit = mkHomeUnitFromFlags dflags + ctx = initSDocContext dflags defaultUserStyle pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) - then getUnitFrameworks dflags dep_packages + then getUnitFrameworks ctx unit_state home_unit dep_packages else return [] let extra_ld_inputs = ldInputs dflags let diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index d642a15147..8231955063 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -110,7 +110,7 @@ import GHC.Utils.Error import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env -import GHC.Unit.Module +import GHC.Unit import GHC.Types.Unique.FM import GHC.Types.Name import GHC.Types.Name.Env @@ -181,15 +181,14 @@ tcRnModule hsc_env mod_sum save_rn_syntax where hsc_src = ms_hsc_src mod_sum dflags = hsc_dflags hsc_env - err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ + home_unit = mkHomeUnitFromFlags dflags + err_msg = mkPlainErrMsg dflags loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod - this_pkg = homeUnit (hsc_dflags hsc_env) - pair :: (Module, SrcSpan) pair@(this_mod,_) | Just (L mod_loc mod) <- hsmodName this_module - = (mkModule this_pkg mod, mod_loc) + = (mkHomeModule home_unit mod, mod_loc) | otherwise -- 'module M where' is omitted = (mAIN, srcLocSpan (srcSpanStart loc)) @@ -2839,12 +2838,12 @@ loadUnqualIfaces hsc_env ictxt = initIfaceTcRn $ do mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) where - this_pkg = homeUnit (hsc_dflags hsc_env) + home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env) unqual_mods = [ nameModule name | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) , let name = gre_name gre - , nameIsFromExternalPackage this_pkg name + , nameIsFromExternalPackage home_unit name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified doc = text "Need interface for module whose export(s) are in scope unqualified" diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index ccc23c3930..113fadd20d 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -61,8 +61,7 @@ import GHC.Types.Id import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Unit.Module -import GHC.Unit.State +import GHC.Unit import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env @@ -174,8 +173,8 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds -- Step 1.5: Make sure we don't have any type synonym cycles ; traceTc "Starting synonym cycle check" (ppr tyclss) - ; this_uid <- fmap homeUnit getDynFlags - ; checkSynCycles this_uid tyclss tyclds + ; home_unit <- mkHomeUnitFromFlags <$> getDynFlags + ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds ; traceTc "Done synonym cycle check" (ppr tyclss) -- Step 2: Perform the validity check on those types/classes @@ -4136,7 +4135,7 @@ checkValidDataCon dflags existential_ok tc con -- when we actually fill in the abstract type. As such, don't -- warn in this case (it gives users the wrong idea about whether -- or not UNPACK on abstract types is supported; it is!) - , homeUnitIsDefinite dflags + , isHomeUnitDefinite (mkHomeUnitFromFlags dflags) = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) where is_strict = case strict_mark of diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index bddda199a8..5dbc90de86 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -21,7 +21,7 @@ module GHC.Tc.Utils.Backpack ( import GHC.Prelude import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) -import GHC.Unit.State +import GHC.Unit import GHC.Tc.Gen.Export import GHC.Driver.Session import GHC.Driver.Ppr @@ -42,7 +42,6 @@ import GHC.Iface.Load import GHC.Rename.Names import GHC.Utils.Error import GHC.Types.Id -import GHC.Unit.Module import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -312,10 +311,11 @@ implicitRequirements' hsc_env normal_imports forM normal_imports $ \(mb_pkg, L _ imp) -> do found <- findImportedModule hsc_env imp mb_pkg case found of - Found _ mod | not (isHomeModule dflags mod) -> + Found _ mod | not (isHomeModule home_unit mod) -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where dflags = hsc_dflags hsc_env + home_unit = mkHomeUnitFromFlags dflags -- | Given a 'Unit', make sure it is well typed. This is because -- unit IDs come from Cabal, which does not know if things are well-typed or @@ -539,6 +539,7 @@ mergeSignatures inner_mod = tcg_semantic_mod tcg_env mod_name = moduleName (tcg_mod tcg_env) pkgstate = unitState dflags + home_unit = mkHomeUnitFromFlags dflags -- STEP 1: Figure out all of the external signature interfaces -- we are going to merge in. @@ -734,7 +735,7 @@ mergeSignatures -- STEP 4: Rename the interfaces ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) -> tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface - lcl_iface <- tcRnModIface (homeUnitInstantiations dflags) (Just nsubst) lcl_iface0 + lcl_iface <- tcRnModIface (homeUnitInstantiations home_unit) (Just nsubst) lcl_iface0 let ifaces = lcl_iface : ext_ifaces -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env @@ -756,7 +757,7 @@ mergeSignatures let infos = zip ifaces detailss -- Test for cycles - checkSynCycles (homeUnit dflags) (typeEnvTyCons type_env) [] + checkSynCycles (homeUnitAsUnit home_unit) (typeEnvTyCons type_env) [] -- NB on type_env: it contains NO dfuns. DFuns are recorded inside -- detailss, and given a Name that doesn't correspond to anything real. See @@ -1000,16 +1001,17 @@ instantiateSignature = do dflags <- getDynFlags let outer_mod = tcg_mod tcg_env inner_mod = tcg_semantic_mod tcg_env + home_unit = mkHomeUnitFromFlags dflags + unit_state = unitState dflags -- TODO: setup the local RdrEnv so the error messages look a little better. -- But this information isn't stored anywhere. Should we RETYPECHECK -- the local one just to get the information? Hmm... - MASSERT( isHomeModule dflags outer_mod ) - MASSERT( isJust (homeUnitInstanceOfId dflags) ) - let uid = fromJust (homeUnitInstanceOfId dflags) + MASSERT( isHomeModule home_unit outer_mod ) + MASSERT( isHomeUnitInstantiating home_unit) -- we need to fetch the most recent ppr infos from the unit -- database because we might have modified it - uid' = updateIndefUnitId (unitState dflags) uid + let uid = mkIndefUnitId unit_state (homeUnitInstanceOf home_unit) inner_mod `checkImplements` Module - (mkInstantiatedUnit uid' (homeUnitInstantiations dflags)) + (mkInstantiatedUnit uid (homeUnitInstantiations home_unit)) (moduleName outer_mod) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 0b92d7b3d2..ea20808f98 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -106,6 +106,7 @@ import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Unit.Module +import GHC.Unit.Home import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Encoding @@ -146,7 +147,8 @@ lookupGlobal_maybe hsc_env name = do { -- Try local envt let mod = icInteractiveModule (hsc_IC hsc_env) dflags = hsc_dflags hsc_env - tcg_semantic_mod = canonicalizeModuleIfHome dflags mod + home_unit = mkHomeUnitFromFlags dflags + tcg_semantic_mod = homeModuleInstantiation home_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 47e1ab8a9d..abdd670483 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -241,6 +241,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this th_remote_state_var <- newIORef Nothing ; let { dflags = hsc_dflags hsc_env ; + home_unit = mkHomeUnitFromFlags dflags ; maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val @@ -266,8 +267,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_th_remote_state = th_remote_state_var, tcg_mod = mod, - tcg_semantic_mod = - canonicalizeModuleIfHome dflags mod, + tcg_semantic_mod = homeModuleInstantiation home_unit mod, tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, @@ -773,7 +773,9 @@ wrapDocLoc doc = do getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified getPrintUnqualified dflags = do { rdr_env <- getGlobalRdrEnv - ; return $ mkPrintUnqualified dflags rdr_env } + ; let unit_state = unitState dflags + ; let home_unit = mkHomeUnitFromFlags dflags + ; return $ mkPrintUnqualified unit_state home_unit rdr_env } -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () @@ -1937,10 +1939,10 @@ initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv ; dflags <- getDynFlags ; let !mod = tcg_semantic_mod tcg_env + home_unit = mkHomeUnitFromFlags dflags -- When we are instantiating a signature, we DEFINITELY -- do not want to knot tie. - is_instantiate = homeUnitIsDefinite dflags && - not (null (homeUnitInstantiations dflags)) + is_instantiate = isHomeUnitInstantiating home_unit ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", if_rec_types = diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index 4a03a5bfc9..6cdf6513d6 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -87,6 +87,7 @@ import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing ) import GHC.Platform import GHC.Types.Name.Occurrence import GHC.Unit.Module +import GHC.Unit.Home import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Utils.Misc @@ -338,10 +339,10 @@ nameIsHomePackageImport this_mod -- | Returns True if the Name comes from some other package: neither this -- package nor the interactive package. -nameIsFromExternalPackage :: Unit -> Name -> Bool -nameIsFromExternalPackage this_unit name +nameIsFromExternalPackage :: HomeUnit -> Name -> Bool +nameIsFromExternalPackage home_unit name | Just mod <- nameModule_maybe name - , moduleUnit mod /= this_unit -- Not the current unit + , notHomeModule home_unit mod -- Not the current unit , not (isInteractiveModule mod) -- Not the 'interactive' package = True | otherwise diff --git a/compiler/GHC/Unit.hs b/compiler/GHC/Unit.hs index c93866ed35..3c167762f4 100644 --- a/compiler/GHC/Unit.hs +++ b/compiler/GHC/Unit.hs @@ -10,6 +10,7 @@ module GHC.Unit , module GHC.Unit.Parser , module GHC.Unit.State , module GHC.Unit.Module + , module GHC.Unit.Home ) where @@ -18,6 +19,7 @@ import GHC.Unit.Info import GHC.Unit.Parser import GHC.Unit.State import GHC.Unit.Module +import GHC.Unit.Home {- diff --git a/compiler/GHC/Unit/Home.hs b/compiler/GHC/Unit/Home.hs new file mode 100644 index 0000000000..eceebd81d0 --- /dev/null +++ b/compiler/GHC/Unit/Home.hs @@ -0,0 +1,213 @@ +-- | The home unit is the unit (i.e. compiled package) that contains the module +-- we are compiling/typechecking. +module GHC.Unit.Home + ( GenHomeUnit (..) + , HomeUnit + , homeUnitId + , homeUnitInstantiations + , homeUnitInstanceOf + , homeUnitInstanceOfMaybe + , homeUnitAsUnit + , homeUnitMap + -- * Predicates + , isHomeUnitIndefinite + , isHomeUnitDefinite + , isHomeUnitInstantiating + , isHomeUnit + , isHomeUnitId + , isHomeUnitInstanceOf + , isHomeModule + , isHomeInstalledModule + , notHomeModule + , notHomeModuleMaybe + , notHomeInstalledModule + , notHomeInstalledModuleMaybe + -- * Helpers + , mkHomeModule + , mkHomeInstalledModule + , homeModuleInstantiation + , homeModuleNameInstantiation + ) +where + +import GHC.Prelude +import GHC.Unit.Types +import GHC.Unit.Module.Name +import Data.Maybe + +-- | Information about the home unit (i.e., the until that will contain the +-- modules we are compiling) +-- +-- The unit identifier of the instantiating units is left open to allow +-- switching from UnitKey (what is provided by the user) to UnitId (internal +-- unit identifier) with `homeUnitMap`. +-- +-- TODO: this isn't implemented yet. UnitKeys are still converted too early into +-- UnitIds in GHC.Unit.State.readUnitDataBase and wiring of home unit +-- instantiations is done inplace in DynFlags by +-- GHC.Unit.State.upd_wired_in_home_instantiations. +data GenHomeUnit u + = DefiniteHomeUnit UnitId (Maybe (u, GenInstantiations u)) + -- ^ Definite home unit (i.e. that we can compile). + -- + -- Nothing: not an instantiated unit + -- Just (i,insts): made definite by instantiating "i" with "insts" + + | IndefiniteHomeUnit UnitId (GenInstantiations u) + -- ^ Indefinite home unit (i.e. that we can only typecheck) + -- + -- All the holes are instantiated with fake modules from the Hole unit. + -- See Note [Representation of module/name variables] in "GHC.Unit" + +type HomeUnit = GenHomeUnit UnitId + +-- | Return home unit id +homeUnitId :: GenHomeUnit u -> UnitId +homeUnitId (DefiniteHomeUnit u _) = u +homeUnitId (IndefiniteHomeUnit u _) = u + +-- | Return home unit instantiations +homeUnitInstantiations :: GenHomeUnit u -> GenInstantiations u +homeUnitInstantiations (DefiniteHomeUnit _ Nothing) = [] +homeUnitInstantiations (DefiniteHomeUnit _ (Just (_,is))) = is +homeUnitInstantiations (IndefiniteHomeUnit _ is) = is + +-- | Return the unit id of the unit that is instantiated by the home unit. +-- +-- E.g. if home unit = q[A=p:B,...] we return q. +-- +-- If the home unit is not an instance of another unit, we return its own unit +-- id (it is an instance of itself if you will). +homeUnitInstanceOf :: HomeUnit -> UnitId +homeUnitInstanceOf h = fromMaybe (homeUnitId h) (homeUnitInstanceOfMaybe h) + +-- | Return the unit id of the unit that is instantiated by the home unit. +-- +-- E.g. if home unit = q[A=p:B,...] we return (Just q). +-- +-- If the home unit is not an instance of another unit, we return Nothing. +homeUnitInstanceOfMaybe :: GenHomeUnit u -> Maybe u +homeUnitInstanceOfMaybe (DefiniteHomeUnit _ (Just (u,_))) = Just u +homeUnitInstanceOfMaybe _ = Nothing + +-- | Return the home unit as a normal unit. +-- +-- We infer from the home unit itself the kind of unit we create: +-- 1. If the home unit is definite, we must be compiling so we return a real +-- unit. The definite home unit may be the result of a unit instantiation, +-- say `p = q[A=r:X]`. In this case we could have returned a virtual unit +-- `q[A=r:X]` but it's not what the clients of this function expect, +-- especially because `p` is lost when we do this. The unit id of a virtual +-- unit is made up internally so `unitId(q[A=r:X])` is not equal to `p`. +-- +-- 2. If the home unit is indefinite we can only create a virtual unit from +-- it. It's ok because we must be only typechecking the home unit so we won't +-- produce any code object that rely on the unit id of this virtual unit. +homeUnitAsUnit :: HomeUnit -> Unit +homeUnitAsUnit (DefiniteHomeUnit u _) = RealUnit (Definite u) +homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit (Indefinite u Nothing) is + +-- | Map over the unit identifier for instantiating units +homeUnitMap :: IsUnitId v => (u -> v) -> GenHomeUnit u -> GenHomeUnit v +homeUnitMap _ (DefiniteHomeUnit u Nothing) = DefiniteHomeUnit u Nothing +homeUnitMap f (DefiniteHomeUnit u (Just (i,is))) = DefiniteHomeUnit u (Just (f i, mapInstantiations f is)) +homeUnitMap f (IndefiniteHomeUnit u is) = IndefiniteHomeUnit u (mapInstantiations f is) + +---------------------------- +-- Predicates +---------------------------- + +-- | Test if we are type-checking an indefinite unit +-- +-- (if it is not, we should never use on-the-fly renaming) +isHomeUnitIndefinite :: GenHomeUnit u -> Bool +isHomeUnitIndefinite (DefiniteHomeUnit {}) = False +isHomeUnitIndefinite (IndefiniteHomeUnit {}) = True + +-- | Test if we are compiling a definite unit +-- +-- (if it is, we should never use on-the-fly renaming) +isHomeUnitDefinite :: GenHomeUnit u -> Bool +isHomeUnitDefinite (DefiniteHomeUnit {}) = True +isHomeUnitDefinite (IndefiniteHomeUnit {}) = False + +-- | Test if we are compiling by instantiating a definite unit +isHomeUnitInstantiating :: GenHomeUnit u -> Bool +isHomeUnitInstantiating u = + isHomeUnitDefinite u && not (null (homeUnitInstantiations u)) + +-- | Test if the unit is the home unit +isHomeUnit :: HomeUnit -> Unit -> Bool +isHomeUnit hu u = u == homeUnitAsUnit hu + +-- | Test if the unit-id is the home unit-id +isHomeUnitId :: GenHomeUnit u -> UnitId -> Bool +isHomeUnitId hu uid = uid == homeUnitId hu + +-- | Test if the home unit is an instance of the given unit-id +isHomeUnitInstanceOf :: HomeUnit -> UnitId -> Bool +isHomeUnitInstanceOf hu u = homeUnitInstanceOf hu == u + +-- | Test if the module comes from the home unit +isHomeModule :: HomeUnit -> Module -> Bool +isHomeModule hu m = isHomeUnit hu (moduleUnit m) + +-- | Test if the module comes from the home unit +isHomeInstalledModule :: GenHomeUnit u -> InstalledModule -> Bool +isHomeInstalledModule hu m = isHomeUnitId hu (moduleUnit m) + + +-- | Test if a module doesn't come from the given home unit +notHomeInstalledModule :: GenHomeUnit u -> InstalledModule -> Bool +notHomeInstalledModule hu m = not (isHomeInstalledModule hu m) + +-- | Test if a module doesn't come from the given home unit +notHomeInstalledModuleMaybe :: Maybe (GenHomeUnit u) -> InstalledModule -> Bool +notHomeInstalledModuleMaybe mh m = fromMaybe True $ fmap (`notHomeInstalledModule` m) mh + + +-- | Test if a module doesn't come from the given home unit +notHomeModule :: HomeUnit -> Module -> Bool +notHomeModule hu m = not (isHomeModule hu m) + +-- | Test if a module doesn't come from the given home unit +notHomeModuleMaybe :: Maybe HomeUnit -> Module -> Bool +notHomeModuleMaybe mh m = fromMaybe True $ fmap (`notHomeModule` m) mh + +---------------------------- +-- helpers +---------------------------- + +-- | Make a module in home unit +mkHomeModule :: HomeUnit -> ModuleName -> Module +mkHomeModule hu = mkModule (homeUnitAsUnit hu) + +-- | Make a module in home unit +mkHomeInstalledModule :: GenHomeUnit u -> ModuleName -> InstalledModule +mkHomeInstalledModule hu = mkModule (homeUnitId hu) + +-- | Return the module that is used to instantiate the given home module name. +-- If the ModuleName doesn't refer to a signature, return the actual home +-- module. +-- +-- E.g., the instantiating module of @A@ in @p[A=q[]:B]@ is @q[]:B@. +-- the instantiating module of @A@ in @p@ is @p:A@. +homeModuleNameInstantiation :: HomeUnit -> ModuleName -> Module +homeModuleNameInstantiation hu mod_name = + case lookup mod_name (homeUnitInstantiations hu) of + Nothing -> mkHomeModule hu mod_name + Just mod -> mod + +-- | Return the module that is used to instantiate the given home module. +-- +-- If the given module isn't a module hole, return the actual home module. +-- +-- E.g., the instantiating module of @p:A@ in @p[A=q[]:B]@ is @q[]:B@. +-- 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) + | otherwise = mod + diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs index 002fb1b6a9..839344804c 100644 --- a/compiler/GHC/Unit/Info.hs +++ b/compiler/GHC/Unit/Info.hs @@ -46,12 +46,6 @@ import GHC.Unit.Ppr -- Units] in "GHC.Unit" type GenUnitInfo unit = GenericUnitInfo (Indefinite unit) PackageId PackageName unit ModuleName (GenModule (GenUnit unit)) --- | A unit key in the database -newtype UnitKey = UnitKey FastString - -unitKeyFS :: UnitKey -> FastString -unitKeyFS (UnitKey fs) = fs - -- | Information about an installed unit (units are identified by their database -- UnitKey) type UnitKeyInfo = GenUnitInfo UnitKey @@ -76,21 +70,21 @@ mkUnitKeyInfo = mapGenericUnitInfo mkModuleName' = mkModuleNameFS . mkFastStringByteString mkIndefUnitKey' cid = Indefinite (mkUnitKey' cid) Nothing mkVirtUnitKey' i = case i of - DbInstUnitId cid insts -> mkGenVirtUnit unitKeyFS (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts) + DbInstUnitId cid insts -> mkVirtUnit (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts) DbUnitId uid -> RealUnit (Definite (mkUnitKey' uid)) mkModule' m = case m of DbModule uid n -> mkModule (mkVirtUnitKey' uid) (mkModuleName' n) DbModuleVar n -> mkHoleModule (mkModuleName' n) -- | Map over the unit parameter -mapUnitInfo :: (u -> v) -> (v -> FastString) -> GenUnitInfo u -> GenUnitInfo v -mapUnitInfo f gunitFS = mapGenericUnitInfo +mapUnitInfo :: IsUnitId v => (u -> v) -> GenUnitInfo u -> GenUnitInfo v +mapUnitInfo f = mapGenericUnitInfo f -- unit identifier (fmap f) -- indefinite unit identifier id -- package identifier id -- package name id -- module name - (fmap (mapGenUnit f gunitFS)) -- instantiating modules + (fmap (mapGenUnit f)) -- instantiating modules -- TODO: there's no need for these to be FastString, as we don't need the uniq -- feature, but ghc doesn't currently have convenient support for any diff --git a/compiler/GHC/Unit/Module.hs b/compiler/GHC/Unit/Module.hs index 6ec97c027a..cb8e6c3fe9 100644 --- a/compiler/GHC/Unit/Module.hs +++ b/compiler/GHC/Unit/Module.hs @@ -43,7 +43,6 @@ module GHC.Unit.Module , moduleIsDefinite , HasModule(..) , ContainsModule(..) - , unitIdEq , installedModuleEq ) where @@ -89,10 +88,6 @@ installedModuleEq :: InstalledModule -> Module -> Bool installedModuleEq imod mod = fst (getModuleInstantiation mod) == imod --- | Test if a 'Unit' corresponds to a given 'UnitId', --- modulo instantiation. -unitIdEq :: UnitId -> Unit -> Bool -unitIdEq iuid uid = toUnitId uid == iuid {- ************************************************************************ diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index db99ffa2ac..123d9a8027 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -71,9 +71,7 @@ module GHC.Unit.State ( -- * Utils mkIndefUnitId, updateIndefUnitId, - unwireUnit, - homeUnitIsIndefinite, - homeUnitIsDefinite, + unwireUnit ) where @@ -82,6 +80,7 @@ where import GHC.Prelude import GHC.Platform +import GHC.Unit.Home import GHC.Unit.Database import GHC.Unit.Info import GHC.Unit.Ppr @@ -316,6 +315,7 @@ instance Monoid UnitVisibility where data UnitConfig = UnitConfig { unitConfigPlatformArchOS :: !ArchOS -- ^ Platform arch and OS , unitConfigWays :: !Ways -- ^ Ways to use + , unitConfigHomeUnit :: !HomeUnit -- ^ Home unit , unitConfigProgramName :: !String -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment -- variables such as "GHC[JS]_PACKAGE_PATH". @@ -329,11 +329,6 @@ data UnitConfig = UnitConfig , unitConfigHideAll :: !Bool -- ^ Hide all units by default , unitConfigHideAllPlugins :: !Bool -- ^ Hide all plugins units by default - , unitConfigAllowVirtualUnits :: !Bool - -- ^ Allow the use of virtual units instantiated on-the-fly (see Note - -- [About units] in GHC.Unit). This should only be used when we are - -- type-checking an indefinite unit (not producing any code). - , unitConfigDBCache :: Maybe [UnitDatabase UnitId] -- ^ Cache of databases to use, in the order they were specified on the -- command line (later databases shadow earlier ones). @@ -349,16 +344,18 @@ data UnitConfig = UnitConfig initUnitConfig :: DynFlags -> UnitConfig initUnitConfig dflags = - let autoLink + let home_unit = mkHomeUnitFromFlags dflags + autoLink | not (gopt Opt_AutoLinkPackages dflags) = [] -- By default we add base & rts to the preload units (when they are -- found in the unit database) except when we are building them - | otherwise = filter (/= homeUnitId dflags) [baseUnitId, rtsUnitId] + | otherwise = filter (not . isHomeUnitId home_unit) [baseUnitId, rtsUnitId] in UnitConfig { unitConfigPlatformArchOS = platformArchOS (targetPlatform dflags) , unitConfigProgramName = programName dflags , unitConfigWays = ways dflags + , unitConfigHomeUnit = home_unit , unitConfigGlobalDB = globalPackageDatabasePath dflags , unitConfigGHCDir = topDir dflags @@ -369,11 +366,6 @@ initUnitConfig dflags = , unitConfigHideAll = gopt Opt_HideAllPackages dflags , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags - -- when the home unit is indefinite, it means we are type-checking it - -- only (not producing any code). Hence we can use virtual units - -- instantiated on-the-fly (see Note [About units] in GHC.Unit) - , unitConfigAllowVirtualUnits = homeUnitIsIndefinite dflags - , unitConfigDBCache = unitDatabases dflags , unitConfigFlagsDB = packageDBFlags dflags , unitConfigFlagsExposed = packageFlags dflags @@ -679,7 +671,7 @@ readUnitDatabase printer cfg conf_file = do conf_file' = dropTrailingPathSeparator conf_file top_dir = unitConfigGHCDir cfg pkgroot = takeDirectory conf_file' - pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) unitIdFS . mkUnitKeyInfo) + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) proto_pkg_configs -- return $ UnitDatabase conf_file' pkg_configs1 @@ -778,16 +770,6 @@ applyTrustFlag ctx prec_map unusable pkgs flag = Left ps -> trustFlagErr ctx flag ps Right (ps,qs) -> return (distrustAllUnits ps ++ qs) --- | A little utility to tell if the home unit is indefinite --- (if it is not, we should never use on-the-fly renaming.) -homeUnitIsIndefinite :: DynFlags -> Bool -homeUnitIsIndefinite dflags = not (homeUnitIsDefinite dflags) - --- | A little utility to tell if the home unit is definite --- (if it is, we should never use on-the-fly renaming.) -homeUnitIsDefinite :: DynFlags -> Bool -homeUnitIsDefinite dflags = unitIsDefinite (homeUnit dflags) - applyPackageFlag :: SDocContext -> UnitPrecedenceMap @@ -1128,11 +1110,11 @@ findWiredInUnits printer prec_map pkgs vis_map = do -- | Some wired units can be used to instantiate the home unit. We need to -- replace their unit keys with their wired unit ids. upd_wired_in_home_instantiations :: DynFlags -> DynFlags -upd_wired_in_home_instantiations dflags = dflags { homeUnitInstantiations = wiredInsts } +upd_wired_in_home_instantiations dflags = dflags { homeUnitInstantiations_ = wiredInsts } where state = unitState dflags wiringMap = wireMap state - unwiredInsts = homeUnitInstantiations dflags + unwiredInsts = homeUnitInstantiations_ dflags wiredInsts = map (fmap (upd_wired_in_mod wiringMap)) unwiredInsts @@ -1647,6 +1629,16 @@ mkUnitState ctx printer cfg = do return (state, raw_dbs) +-- | Do we allow the use of virtual units instantiated on-the-fly (see Note +-- [About units] in GHC.Unit). This should only be true when we are +-- type-checking an indefinite unit (not producing any code). +unitConfigAllowVirtualUnits :: UnitConfig -> Bool +unitConfigAllowVirtualUnits cfg = + -- when the home unit is indefinite, it means we are type-checking it only + -- (not producing any code). Hence we can use virtual units instantiated + -- on-the-fly (see Note [About units] in GHC.Unit) + isHomeUnitIndefinite (unitConfigHomeUnit cfg) + -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' -- that it was recorded as in the package database. unwireUnit :: UnitState -> Unit-> Unit @@ -1796,27 +1788,31 @@ mkModMap pkg mod = Map.singleton (mkModule pkg mod) -- use. -- | Find all the include directories in these and the preload packages -getUnitIncludePath :: DynFlags -> [UnitId] -> IO [String] -getUnitIncludePath dflags pkgs = - collectIncludeDirs `fmap` getPreloadUnitsAnd dflags pkgs +getUnitIncludePath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] +getUnitIncludePath ctx unit_state home_unit pkgs = + collectIncludeDirs `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs collectIncludeDirs :: [UnitInfo] -> [FilePath] collectIncludeDirs ps = ordNub (filter notNull (concatMap unitIncludeDirs ps)) -- | Find all the library paths in these and the preload packages -getUnitLibraryPath :: DynFlags -> [UnitId] -> IO [String] -getUnitLibraryPath dflags pkgs = - collectLibraryPaths dflags `fmap` getPreloadUnitsAnd dflags pkgs +getUnitLibraryPath :: SDocContext -> UnitState -> HomeUnit -> Ways -> [UnitId] -> IO [String] +getUnitLibraryPath ctx unit_state home_unit ws pkgs = + collectLibraryPaths ws `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs -collectLibraryPaths :: DynFlags -> [UnitInfo] -> [FilePath] -collectLibraryPaths dflags = ordNub . filter notNull - . concatMap (libraryDirsForWay dflags) +collectLibraryPaths :: Ways -> [UnitInfo] -> [FilePath] +collectLibraryPaths ws = ordNub . filter notNull + . concatMap (libraryDirsForWay ws) -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags) getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String]) getUnitLinkOpts dflags pkgs = - collectLinkOpts dflags `fmap` getPreloadUnitsAnd dflags pkgs + collectLinkOpts dflags `fmap` getPreloadUnitsAnd + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + pkgs collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String]) collectLinkOpts dflags ps = @@ -1830,14 +1826,18 @@ collectArchives dflags pc = filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a") | searchPath <- searchPaths , lib <- libs ] - where searchPaths = ordNub . filter notNull . libraryDirsForWay dflags $ pc + where searchPaths = ordNub . filter notNull . libraryDirsForWay (ways dflags) $ pc libs = packageHsLibs dflags pc ++ unitExtDepLibsSys pc getLibs :: DynFlags -> [UnitId] -> IO [(String,String)] getLibs dflags pkgs = do - ps <- getPreloadUnitsAnd dflags pkgs + ps <- getPreloadUnitsAnd + (initSDocContext dflags defaultUserStyle) + (unitState dflags) + (mkHomeUnitFromFlags dflags) + pkgs fmap concat . forM ps $ \p -> do - let candidates = [ (l </> f, f) | l <- collectLibraryPaths dflags [p] + let candidates = [ (l </> f, f) | l <- collectLibraryPaths (ways dflags) [p] , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] filterM (doesFileExist . fst) candidates @@ -1890,27 +1890,27 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (unitLibraries p) | otherwise = '_':t -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. -libraryDirsForWay :: DynFlags -> UnitInfo -> [String] -libraryDirsForWay dflags - | WayDyn `elem` ways dflags = unitLibraryDynDirs - | otherwise = unitLibraryDirs +libraryDirsForWay :: Ways -> UnitInfo -> [String] +libraryDirsForWay ws + | WayDyn `elem` ws = unitLibraryDynDirs + | otherwise = unitLibraryDirs -- | Find all the C-compiler options in these and the preload packages -getUnitExtraCcOpts :: DynFlags -> [UnitId] -> IO [String] -getUnitExtraCcOpts dflags pkgs = do - ps <- getPreloadUnitsAnd dflags pkgs +getUnitExtraCcOpts :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] +getUnitExtraCcOpts ctx unit_state home_unit pkgs = do + ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs return (concatMap unitCcOptions ps) -- | Find all the package framework paths in these and the preload packages -getUnitFrameworkPath :: DynFlags -> [UnitId] -> IO [String] -getUnitFrameworkPath dflags pkgs = do - ps <- getPreloadUnitsAnd dflags pkgs +getUnitFrameworkPath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] +getUnitFrameworkPath ctx unit_state home_unit pkgs = do + ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs return (ordNub (filter notNull (concatMap unitExtDepFrameworkDirs ps))) -- | Find all the package frameworks in these and the preload packages -getUnitFrameworks :: DynFlags -> [UnitId] -> IO [String] -getUnitFrameworks dflags pkgs = do - ps <- getPreloadUnitsAnd dflags pkgs +getUnitFrameworks :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] +getUnitFrameworks ctx unit_state home_unit pkgs = do + ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs return (concatMap unitExtDepFrameworks ps) -- ----------------------------------------------------------------------------- @@ -2036,27 +2036,24 @@ listVisibleModuleNames state = map fst (filter visible (Map.toList (moduleNameProvidersMap state))) where visible (_, ms) = any originVisible (Map.elems ms) --- | Lookup 'UnitInfo' for every preload unit, for every unit used to --- instantiate the current unit, and for every unit explicitly passed in the --- given list of UnitId. -getPreloadUnitsAnd :: DynFlags -> [UnitId] -> IO [UnitInfo] -getPreloadUnitsAnd dflags ids0 = +-- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit +-- used to instantiate the home unit, and for every unit explicitly passed in +-- the given list of UnitId. +getPreloadUnitsAnd :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo] +getPreloadUnitsAnd ctx unit_state home_unit ids0 = let - ids = ids0 ++ - -- An indefinite package will have insts to HOLE, - -- which is not a real package. Don't look it up. - -- Fixes #14525 - if homeUnitIsIndefinite dflags - then [] - else map (toUnitId . moduleUnit . snd) - (homeUnitInstantiations dflags) - state = unitState dflags - pkg_map = unitInfoMap state - preload = preloadUnits state - ctx = initSDocContext dflags defaultUserStyle + ids = ids0 ++ inst_ids + inst_ids + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + | isHomeUnitIndefinite home_unit = [] + | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) + pkg_map = unitInfoMap unit_state + preload = preloadUnits unit_state in do all_pkgs <- throwErr ctx (closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing)) - return (map (unsafeLookupUnitId state) all_pkgs) + return (map (unsafeLookupUnitId unit_state) all_pkgs) throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a throwErr ctx m = case m of @@ -2131,14 +2128,12 @@ lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo lookupUnitPprInfo state uid = fmap (mkUnitPprInfo unitIdFS) (lookupUnitId state uid) -- | Create a IndefUnitId. -mkIndefUnitId :: UnitState -> FastString -> IndefUnitId -mkIndefUnitId state raw = - let uid = UnitId raw - in Indefinite uid $! lookupUnitPprInfo state uid +mkIndefUnitId :: UnitState -> UnitId -> IndefUnitId +mkIndefUnitId state uid = Indefinite uid $! lookupUnitPprInfo state uid -- | Update component ID details from the database updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId -updateIndefUnitId pkgstate uid = mkIndefUnitId pkgstate (unitIdFS (indefUnit uid)) +updateIndefUnitId pkgstate uid = mkIndefUnitId pkgstate (indefUnit uid) -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Unit/State.hs-boot b/compiler/GHC/Unit/State.hs-boot index a3bc8fa7d6..4107962941 100644 --- a/compiler/GHC/Unit/State.hs-boot +++ b/compiler/GHC/Unit/State.hs-boot @@ -7,5 +7,6 @@ data UnitState data UnitDatabase unit emptyUnitState :: UnitState +mkIndefUnitId :: UnitState -> UnitId -> IndefUnitId pprUnitIdForUser :: UnitState -> UnitId -> SDoc updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index c8847c8215..c402461630 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} @@ -20,21 +19,22 @@ module GHC.Unit.Types , moduleFreeHoles -- * Units + , IsUnitId , GenUnit (..) , Unit , UnitId (..) + , UnitKey (..) , GenInstantiatedUnit (..) , InstantiatedUnit , IndefUnitId , DefUnitId , Instantiations , GenInstantiations - , mkGenInstantiatedUnit , mkInstantiatedUnit , mkInstantiatedUnitHash - , mkGenVirtUnit , mkVirtUnit , mapGenUnit + , mapInstantiations , unitFreeModuleHoles , fsToUnit , unitFS @@ -44,6 +44,7 @@ module GHC.Unit.Types , stringToUnit , stableUnitCmp , unitIsDefinite + , isHoleUnit -- * Unit Ids , unitIdString @@ -166,6 +167,30 @@ instance Outputable InstantiatedUnit where cid = instUnitInstanceOf uid insts = instUnitInsts uid +-- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit) +-- +-- We need this class because we create new unit ids for virtual units (see +-- VirtUnit) and they have to to be made from units with different kinds of +-- identifiers. +class IsUnitId u where + unitFS :: u -> FastString + +instance IsUnitId UnitKey where + unitFS (UnitKey fs) = fs + +instance IsUnitId UnitId where + unitFS (UnitId fs) = fs + +instance IsUnitId u => IsUnitId (GenUnit u) where + unitFS (VirtUnit x) = instUnitFS x + unitFS (RealUnit (Definite x)) = unitFS x + unitFS HoleUnit = holeFS + +instance IsUnitId u => IsUnitId (Definite u) where + unitFS (Definite x) = unitFS x + +instance IsUnitId u => IsUnitId (Indefinite u) where + unitFS (Indefinite x _) = unitFS x pprModule :: Module -> SDoc pprModule mod@(Module p n) = getPprStyle doc @@ -192,6 +217,9 @@ pprInstantiatedModule (Module uid m) = -- UNITS --------------------------------------------------------------------- +-- | A unit key in the database +newtype UnitKey = UnitKey FastString + -- | A unit identifier identifies a (possibly partially) instantiated library. -- It is primarily used as part of 'Module', which in turn is used in 'Name', -- which is used to give names to entities when typechecking. @@ -261,6 +289,10 @@ holeUnique = getUnique holeFS holeFS :: FastString holeFS = fsLit "<hole>" +isHoleUnit :: GenUnit u -> Bool +isHoleUnit HoleUnit = True +isHoleUnit _ = False + instance Eq (GenInstantiatedUnit unit) where u1 == u2 = instUnitKey u1 == instUnitKey u2 @@ -284,10 +316,10 @@ instance Binary InstantiatedUnit where instUnitKey = getUnique fs } -instance Eq Unit where +instance IsUnitId u => Eq (GenUnit u) where uid1 == uid2 = unitUnique uid1 == unitUnique uid2 -instance Uniquable Unit where +instance IsUnitId u => Uniquable (GenUnit u) where getUnique = unitUnique instance Ord Unit where @@ -357,8 +389,8 @@ moduleFreeHoles (Module u _ ) = unitFreeModuleHoles u -- | Create a new 'GenInstantiatedUnit' given an explicit module substitution. -mkGenInstantiatedUnit :: (unit -> FastString) -> Indefinite unit -> GenInstantiations unit -> GenInstantiatedUnit unit -mkGenInstantiatedUnit gunitFS cid insts = +mkInstantiatedUnit :: IsUnitId u => Indefinite u -> GenInstantiations u -> GenInstantiatedUnit u +mkInstantiatedUnit cid insts = InstantiatedUnit { instUnitInstanceOf = cid, instUnitInsts = sorted_insts, @@ -367,22 +399,14 @@ mkGenInstantiatedUnit gunitFS cid insts = instUnitKey = getUnique fs } where - fs = mkGenInstantiatedUnitHash gunitFS cid sorted_insts + fs = mkInstantiatedUnitHash cid sorted_insts sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts --- | Create a new 'InstantiatedUnit' given an explicit module substitution. -mkInstantiatedUnit :: IndefUnitId -> Instantiations -> InstantiatedUnit -mkInstantiatedUnit = mkGenInstantiatedUnit unitIdFS - -- | Smart constructor for instantiated GenUnit -mkGenVirtUnit :: (unit -> FastString) -> Indefinite unit -> [(ModuleName, GenModule (GenUnit unit))] -> GenUnit unit -mkGenVirtUnit _gunitFS uid [] = RealUnit $ Definite (indefUnit uid) -- huh? indefinite unit without any instantiation/hole? -mkGenVirtUnit gunitFS uid insts = VirtUnit $ mkGenInstantiatedUnit gunitFS uid insts - --- | Smart constructor for VirtUnit -mkVirtUnit :: IndefUnitId -> Instantiations -> Unit -mkVirtUnit = mkGenVirtUnit unitIdFS +mkVirtUnit :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u +mkVirtUnit uid [] = RealUnit $ Definite (indefUnit uid) -- huh? indefinite unit without any instantiation/hole? +mkVirtUnit uid insts = VirtUnit $ mkInstantiatedUnit uid insts -- | Generate a uniquely identifying hash (internal unit-id) for an instantiated -- unit. @@ -392,24 +416,21 @@ mkVirtUnit = mkGenVirtUnit unitIdFS -- This hash is completely internal to GHC and is not used for symbol names or -- file paths. It is different from the hash Cabal would produce for the same -- instantiated unit. -mkGenInstantiatedUnitHash :: (unit -> FastString) -> Indefinite unit -> [(ModuleName, GenModule (GenUnit unit))] -> FastString -mkGenInstantiatedUnitHash gunitFS cid sorted_holes = +mkInstantiatedUnitHash :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> FastString +mkInstantiatedUnitHash cid sorted_holes = mkFastStringByteString - . fingerprintUnitId (bytesFS (gunitFS (indefUnit cid))) - $ hashInstantiations gunitFS sorted_holes - -mkInstantiatedUnitHash :: IndefUnitId -> Instantiations -> FastString -mkInstantiatedUnitHash = mkGenInstantiatedUnitHash unitIdFS + . fingerprintUnitId (bytesFS (unitFS cid)) + $ hashInstantiations sorted_holes -- | Generate a hash for a sorted module instantiation. -hashInstantiations :: (unit -> FastString) -> [(ModuleName, GenModule (GenUnit unit))] -> Fingerprint -hashInstantiations gunitFS sorted_holes = +hashInstantiations :: IsUnitId u => [(ModuleName, GenModule (GenUnit u))] -> Fingerprint +hashInstantiations sorted_holes = fingerprintByteString . BS.concat $ do (m, b) <- sorted_holes - [ bytesFS (moduleNameFS m), BS.Char8.singleton ' ', - bytesFS (genUnitFS gunitFS (moduleUnit b)), BS.Char8.singleton ':', - bytesFS (moduleNameFS (moduleName b)), BS.Char8.singleton '\n'] + [ bytesFS (moduleNameFS m), BS.Char8.singleton ' ', + bytesFS (unitFS (moduleUnit b)), BS.Char8.singleton ':', + bytesFS (moduleNameFS (moduleName b)), BS.Char8.singleton '\n'] fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString fingerprintUnitId prefix (Fingerprint a b) @@ -419,42 +440,37 @@ fingerprintUnitId prefix (Fingerprint a b) , BS.Char8.pack (toBase62Padded a) , BS.Char8.pack (toBase62Padded b) ] -unitUnique :: Unit -> Unique +unitUnique :: IsUnitId u => GenUnit u -> Unique unitUnique (VirtUnit x) = instUnitKey x -unitUnique (RealUnit (Definite x)) = getUnique x +unitUnique (RealUnit (Definite x)) = getUnique (unitFS x) unitUnique HoleUnit = holeUnique -unitFS :: Unit -> FastString -unitFS = genUnitFS unitIdFS - -genUnitFS :: (unit -> FastString) -> GenUnit unit -> FastString -genUnitFS _gunitFS (VirtUnit x) = instUnitFS x -genUnitFS gunitFS (RealUnit (Definite x)) = gunitFS x -genUnitFS _gunitFS HoleUnit = holeFS - -- | Create a new simple unit identifier from a 'FastString'. Internally, -- this is primarily used to specify wired-in unit identifiers. fsToUnit :: FastString -> Unit fsToUnit = RealUnit . Definite . UnitId -unitString :: Unit -> String +unitString :: IsUnitId u => u -> String unitString = unpackFS . unitFS stringToUnit :: String -> Unit stringToUnit = fsToUnit . mkFastString -- | Map over the unit type of a 'GenUnit' -mapGenUnit :: (u -> v) -> (v -> FastString) -> GenUnit u -> GenUnit v -mapGenUnit f gunitFS = go +mapGenUnit :: IsUnitId v => (u -> v) -> GenUnit u -> GenUnit v +mapGenUnit f = go where go gu = case gu of HoleUnit -> HoleUnit RealUnit d -> RealUnit (fmap f d) VirtUnit i -> - VirtUnit $ mkGenInstantiatedUnit gunitFS + VirtUnit $ mkInstantiatedUnit (fmap f (instUnitInstanceOf i)) (fmap (second (fmap go)) (instUnitInsts i)) +-- | Map over the unit identifier of unit instantiations. +mapInstantiations :: IsUnitId v => (u -> v) -> GenInstantiations u -> GenInstantiations v +mapInstantiations f = map (second (fmap (mapGenUnit f))) -- | Return the UnitId of the Unit. For on-the-fly instantiated units, return -- the UnitId of the indefinite unit this unit is an instance of. diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a321aca4dd..2c2d2f4e26 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -201,6 +201,7 @@ Library GHC.CmmToLlvm.Mangler GHC.Types.Id.Make GHC.Unit + GHC.Unit.Home GHC.Unit.Parser GHC.Unit.Ppr GHC.Unit.Types diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 7cef2dd423..948cc74a71 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -57,10 +57,8 @@ import GHC.Hs import GHC.Driver.Types ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc, hsc_dynLinker, hsc_interp, emptyModBreaks ) -import GHC.Unit.Module +import GHC.Unit import GHC.Types.Name -import GHC.Unit.State ( unitIsTrusted, unsafeLookupUnit, unsafeLookupUnitId, - listVisibleModuleNames, pprFlag, preloadUnits ) import GHC.Iface.Syntax ( showToHeader ) import GHC.Core.Ppr.TyThing import GHC.Builtin.Names @@ -2363,13 +2361,13 @@ isSafeModule m = do mname = GHC.moduleNameString $ GHC.moduleName m packageTrusted dflags md - | isHomeModule dflags md = True + | isHomeModule (mkHomeUnitFromFlags dflags) md = True | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit md) tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty) | otherwise = S.partition part deps - where part pkg = unitIsTrusted $ unsafeLookupUnitId pkgstate pkg - pkgstate = unitState dflags + where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg + unit_state = unitState dflags ----------------------------------------------------------------------------- -- :browse @@ -4316,8 +4314,8 @@ wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module wantInterpretedModuleName modname = do modl <- lookupModuleName modname let str = moduleNameString modname - dflags <- getDynFlags - unless (isHomeModule dflags modl) $ + home_unit <- mkHomeUnitFromFlags <$> getDynFlags + unless (isHomeModule home_unit modl) $ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) is_interpreted <- GHC.moduleIsInterpreted modl when (not is_interpreted) $ diff --git a/utils/haddock b/utils/haddock -Subproject 7de9589e0191bbd79521597d35c2a0c68d2c9ad +Subproject 323aa89cbb4a3e8c8f32295e42a42635f05c849 |