diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-08-05 11:32:17 +0200 |
|---|---|---|
| committer | Sylvain Henry <sylvain@haskus.fr> | 2020-08-13 09:49:56 -0400 |
| commit | ffc0d578ea22de02a68c64c094602701e65d8895 (patch) | |
| tree | 168171a5fb54632f5f4fdd1130a31ed730248e73 /compiler | |
| parent | cf97889a38edc3314a7b61e6e0b6e6d0f434c8a2 (diff) | |
| download | haskell-ffc0d578ea22de02a68c64c094602701e65d8895.tar.gz | |
Add HomeUnit type
Since Backpack the "home unit" is much more involved than what it was
before (just an identifier obtained with `-this-unit-id`). Now it is
used in conjunction with `-component-id` and `-instantiated-with` to
configure module instantiations and to detect if we are type-checking an
indefinite unit or compiling a definite one.
This patch introduces a new HomeUnit datatype which is much easier to
understand. Moreover to make GHC support several packages in the same
instances, we will need to handle several HomeUnits so having a
dedicated (documented) type is helpful.
Finally in #14335 we will also need to handle the case where we have no
HomeUnit at all because we are only loading existing interfaces for
plugins which live in a different space compared to units used to
produce target code. Several functions will have to be refactored to
accept "Maybe HomeUnit" parameters instead of implicitly querying the
HomeUnit fields in DynFlags. Having a dedicated type will make this
easier.
Bump haddock submodule
Diffstat (limited to 'compiler')
40 files changed, 666 insertions, 384 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 |