diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-04-03 12:18:57 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-04-30 01:56:56 -0400 |
| commit | 10d15f1ec4bab4dd6152d87fc66e61658a705eb3 (patch) | |
| tree | c25e1b33f62e13db7a3163f4e74330a52add80a2 | |
| parent | ea717aa4248b2122e1f7550f30239b50ab560e4f (diff) | |
| download | haskell-10d15f1ec4bab4dd6152d87fc66e61658a705eb3.tar.gz | |
Refactoring unit management code
Over the years the unit management code has been modified a lot to keep
up with changes in Cabal (e.g. support for several library components in
the same package), to integrate BackPack, etc. I found it very hard to
understand as the terminology wasn't consistent, was referring to past
concepts, etc.
The terminology is now explained as clearly as I could in the Note
"About Units" and the code is refactored to reflect it.
-------------------
Many names were misleading: UnitId is not an Id but could be a virtual
unit (an indefinite one instantiated on the fly), IndefUnitId
constructor may contain a definite instantiated unit, etc.
* Rename IndefUnitId into InstantiatedUnit
* Rename IndefModule into InstantiatedModule
* Rename UnitId type into Unit
* Rename IndefiniteUnitId constructor into VirtUnit
* Rename DefiniteUnitId constructor into RealUnit
* Rename packageConfigId into mkUnit
* Rename getPackageDetails into unsafeGetUnitInfo
* Rename InstalledUnitId into UnitId
Remove references to misleading ComponentId: a ComponentId is just an
indefinite unit-id to be instantiated.
* Rename ComponentId into IndefUnitId
* Rename ComponentDetails into UnitPprInfo
* Fix display of UnitPprInfo with empty version: this is now used for
units dynamically generated by BackPack
Generalize several types (Module, Unit, etc.) so that they can be used
with different unit identifier types: UnitKey, UnitId, Unit, etc.
* GenModule: Module, InstantiatedModule and InstalledModule are now
instances of this type
* Generalize DefUnitId, IndefUnitId, Unit, InstantiatedUnit,
PackageDatabase
Replace BackPack fake "hole" UnitId by a proper HoleUnit constructor.
Add basic support for UnitKey. They should be used more in the future to
avoid mixing them up with UnitId as we do now.
Add many comments.
Update Haddock submodule
67 files changed, 1335 insertions, 1147 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index a46218665a..d6878ad63d 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -159,11 +159,11 @@ module GHC ( -- * Abstract syntax elements - -- ** Packages - UnitId, + -- ** Units + Unit, -- ** Modules - Module, mkModule, pprModule, moduleName, moduleUnitId, + Module, mkModule, pprModule, moduleName, moduleUnit, ModuleName, mkModuleName, moduleNameString, -- ** Names @@ -594,7 +594,7 @@ checkBrokenTablesNextToCode' dflags -- flags. If you are not doing linking or doing static linking, you -- can ignore the list of packages returned. -- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] +setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId] setSessionDynFlags dflags = do dflags' <- checkNewDynFlags dflags dflags'' <- liftIO $ interpretPackageEnv dflags' @@ -643,7 +643,7 @@ setSessionDynFlags dflags = do -- | Sets the program 'DynFlags'. Note: this invalidates the internal -- cached module graph, causing more work to be done the next time -- 'load' is called. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] +setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId] setProgramDynFlags dflags = setProgramDynFlags_ True dflags -- | Set the action taken when the compiler produces a message. This @@ -655,7 +655,7 @@ setLogAction action = do void $ setProgramDynFlags_ False $ dflags' { log_action = action } -setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId] +setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [UnitId] setProgramDynFlags_ invalidate_needed dflags = do dflags' <- checkNewDynFlags dflags dflags_prev <- getProgramDynFlags @@ -1357,7 +1357,7 @@ packageDbModules only_exposed = do [ mkModule pid modname | p <- pkgs , not only_exposed || exposed p - , let pid = packageConfigId p + , let pid = mkUnit p , modname <- exposedModules p ++ map exportName (reexportedModules p) ] -} @@ -1489,7 +1489,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do this_pkg = thisPackage dflags -- case maybe_pkg of - Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m -> return m @@ -1501,7 +1501,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 | moduleUnitId m /= this_pkg -> return m + Found loc m | moduleUnit m /= this_pkg -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError dflags noSrcSpan mod_name err @@ -1545,7 +1545,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 1c53df523b..1a7a03fe8a 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -44,7 +44,7 @@ import GHC.Types.Basic ( Arity, Fixity(..), FixityDirection(..), Boxity(..), import GHC.Types.SrcLoc ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString ) import GHC.Types.Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique ) -import GHC.Types.Module ( UnitId ) +import GHC.Types.Module ( Unit ) import GHC.Utils.Outputable import GHC.Data.FastString @@ -704,7 +704,7 @@ pprPrimOp other_op = pprOccName (primOpOcc other_op) ************************************************************************ -} -data PrimCall = PrimCall CLabelString UnitId +data PrimCall = PrimCall CLabelString Unit instance Outputable PrimCall where ppr (PrimCall lbl pkgId) diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs index 3b61d1f889..9a1e562c2a 100644 --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -164,7 +164,7 @@ nameToCLabel n suffix = mkFastString label where encodeZ = zString . zEncodeFS (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n - packagePart = encodeZ (unitIdFS pkgKey) + packagePart = encodeZ (unitFS pkgKey) modulePart = encodeZ (moduleNameFS modName) occPart = encodeZ (occNameFS (nameOccName n)) diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index af1d7a6e98..ba9fecbd08 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -187,7 +187,7 @@ data CLabel -- | A label from a .cmm file that is not associated with a .hs level Id. | CmmLabel - UnitId -- what package the label belongs to. + Unit -- what package the label belongs to. FastString -- identifier giving the prefix of the label CmmLabelInfo -- encodes the suffix of the label @@ -354,7 +354,7 @@ instance Ord CLabel where data ForeignLabelSource -- | Label is in a named package - = ForeignLabelInPackage UnitId + = ForeignLabelInPackage Unit -- | Label is in some external, system package that doesn't also -- contain compiled Haskell code, and is not associated with any .hi files. @@ -553,7 +553,7 @@ mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo ----- mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel - :: UnitId -> FastString -> CLabel + :: Unit -> FastString -> CLabel mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry @@ -1082,7 +1082,7 @@ labelDynamic config this_mod lbl = externalDynamicRefs = ncgExternalDynamicRefs config platform = ncgPlatform config os = platformOS platform - this_pkg = moduleUnitId this_mod + this_pkg = moduleUnit this_mod ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 7da85271f6..8e35e83b6a 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -585,7 +585,7 @@ importName -- A label imported with an explicit packageId. | STRING NAME - { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) } + { ($2, mkCmmCodeLabel (fsToUnit (mkFastString $1)) $2) } names :: { [FastString] } @@ -1163,7 +1163,7 @@ profilingInfo dflags desc_str ty_str then NoProfilingInfo else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) -staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () +staticClosure :: Unit -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload = do dflags <- getDynFlags let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs index cbd15d0580..6879a8c41c 100644 --- a/compiler/GHC/CmmToAsm/Config.hs +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -9,12 +9,12 @@ where import GHC.Prelude import GHC.Platform import GHC.Cmm.Type (Width(..)) -import GHC.Types.Module +import GHC.Unit.Module -- | Native code generator configuration data NCGConfig = NCGConfig { ncgPlatform :: !Platform -- ^ Target platform - , ncgUnitId :: UnitId -- ^ Target unit ID + , ncgUnitId :: Unit -- ^ Target unit ID , ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment , ncgDebugLevel :: !Int -- ^ Debug level , ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 0a1955eacf..68b6ac3bfa 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -1391,7 +1391,7 @@ dataConRepArgTys (MkData { dcRep = rep dataConIdentity :: DataCon -> ByteString -- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat - [ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod)) + [ BSB.byteString $ bytesFS (unitFS (moduleUnit mod)) , BSB.int8 $ fromIntegral (ord ':') , BSB.byteString $ bytesFS (moduleNameFS (moduleName mod)) , BSB.int8 $ fromIntegral (ord '.') diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 2ced161775..8dfada00af 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -25,7 +25,7 @@ import GHC.Driver.Backpack.Syntax import GHC.Parser.Annotation import GHC hiding (Failed, Succeeded) -import GHC.Driver.Packages +import GHC.Driver.Packages hiding (packageNameMap) import GHC.Parser import GHC.Parser.Lexer import GHC.Driver.Monad @@ -96,14 +96,14 @@ doBackpack [src_filename] = do innerBkpM $ do let (cid, insts) = computeUnitId lunit if null insts - then if cid == ComponentId (fsLit "main") Nothing + then if cid == Indefinite (UnitId (fsLit "main")) Nothing then compileExe lunit else compileUnit cid [] else typecheckUnit cid insts doBackpack _ = throwGhcException (CmdLineError "--backpack can only process a single file") -computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)]) +computeUnitId :: LHsUnit HsComponentId -> (IndefUnitId, [(ModuleName, Module)]) computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) where cid = hsComponentId (unLoc (hsunitName unit)) @@ -112,7 +112,7 @@ computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = - unitIdFreeHoles (convertHsUnitId hsuid) + unitFreeModuleHoles (convertHsComponentId hsuid) -- | Tiny enum for all types of Backpack operations we may do. data SessionType @@ -129,17 +129,17 @@ data SessionType -- | Create a temporary Session to do some sort of type checking or -- compilation. -withBkpSession :: ComponentId +withBkpSession :: IndefUnitId -> [(ModuleName, Module)] - -> [(UnitId, ModRenaming)] + -> [(Unit, ModRenaming)] -> SessionType -- what kind of session are we doing -> BkpM a -- actual action to run -> BkpM a withBkpSession cid insts deps session_type do_this = do dflags <- getDynFlags - let (ComponentId cid_fs _) = cid + let cid_fs = unitIdFS (indefUnit cid) is_primary = False - uid_str = unpackFS (hashUnitId cid insts) + uid_str = unpackFS (mkInstantiatedUnitHash cid insts) cid_str = unpackFS cid_fs -- There are multiple units in a single Backpack file, so we -- need to separate out the results in those cases. Right now, @@ -174,12 +174,12 @@ withBkpSession cid insts deps session_type do_this = do _ -> hscTarget dflags, thisUnitIdInsts_ = Just insts, thisComponentId_ = Just cid, - thisInstalledUnitId = + thisUnitId = case session_type of - TcSession -> newInstalledUnitId cid Nothing + TcSession -> newUnitId cid Nothing -- No hash passed if no instances - _ | null insts -> newInstalledUnitId cid Nothing - | otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)), + _ | null insts -> newUnitId cid Nothing + | otherwise -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)), -- Setup all of the output directories according to our hierarchy objectDir = Just (outdir objectDir), hiDir = Just (outdir hiDir), @@ -192,7 +192,7 @@ withBkpSession cid insts deps session_type do_this = do importPaths = [], -- Synthesized the flags packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnitId dflags (improveUnitId (getUnitInfoMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0) + let uid = unwireUnit dflags (improveUnit (getUnitInfoMap dflags) $ renameHoleUnit dflags (listToUFM insts) uid0) in ExposePackage (showSDoc dflags (text "-unit-id" <+> ppr uid <+> ppr rn)) @@ -204,41 +204,41 @@ withBkpSession cid insts deps session_type do_this = do _ <- setSessionDynFlags dflags do_this -withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a +withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a withBkpExeSession deps do_this = do - withBkpSession (ComponentId (fsLit "main") Nothing) [] deps ExeSession do_this + withBkpSession (Indefinite (UnitId (fsLit "main")) Nothing) [] deps ExeSession do_this -getSource :: ComponentId -> BkpM (LHsUnit HsComponentId) +getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId) getSource cid = do bkp_env <- getBkpEnv case Map.lookup cid (bkp_table bkp_env) of Nothing -> pprPanic "missing needed dependency" (ppr cid) Just lunit -> return lunit -typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () +typecheckUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM () typecheckUnit cid insts = do lunit <- getSource cid buildUnit TcSession cid insts lunit -compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () +compileUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM () compileUnit cid insts = do - -- Let everyone know we're building this unit ID - msgUnitId (newUnitId cid insts) + -- Let everyone know we're building this unit + msgUnitId (mkVirtUnit cid insts) lunit <- getSource cid buildUnit CompSession cid insts lunit -- | Compute the dependencies with instantiations of a syntactic -- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a --- unit file, return the 'UnitId' corresponding to @p[A=<A>]@. +-- unit file, return the 'Unit' corresponding to @p[A=<A>]@. -- The @include_sigs@ parameter controls whether or not we also -- include @dependency signature@ declarations in this calculation. -- --- Invariant: this NEVER returns InstalledUnitId. -hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)] +-- Invariant: this NEVER returns UnitId. +hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)] hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) where get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) - | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)] + | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)] | otherwise = [] where go Nothing = ModRenaming True [] @@ -248,7 +248,7 @@ hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) get_dep _ = [] -buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () +buildUnit :: SessionType -> IndefUnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () buildUnit session cid insts lunit = do -- NB: include signature dependencies ONLY when typechecking. -- If we're compiling, it's not necessary to recursively @@ -260,7 +260,7 @@ buildUnit session cid insts lunit = do -- The compilation dependencies are just the appropriately filled -- in unit IDs which must be compiled before we can compile. let hsubst = listToUFM insts - deps0 = map (renameHoleUnitId dflags hsubst) raw_deps + deps0 = map (renameHoleUnit dflags hsubst) raw_deps -- Build dependencies OR make sure they make sense. BUT NOTE, -- we can only check the ones that are fully filled; the rest @@ -273,7 +273,7 @@ buildUnit session cid insts lunit = do dflags <- getDynFlags -- IMPROVE IT - let deps = map (improveUnitId (getUnitInfoMap dflags)) deps0 + let deps = map (improveUnit (getUnitInfoMap dflags)) deps0 mb_old_eps <- case session of TcSession -> fmap Just getEpsGhc @@ -304,7 +304,7 @@ buildUnit session cid insts lunit = do getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables - let compat_fs = (case cid of ComponentId fs _ -> fs) + let compat_fs = unitIdFS (indefUnit cid) compat_pn = PackageName compat_fs return GenericUnitInfo { @@ -312,8 +312,8 @@ buildUnit session cid insts lunit = do unitAbiHash = "", unitPackageId = PackageId compat_fs, unitPackageName = compat_pn, - unitPackageVersion = makeVersion [0], - unitId = toInstalledUnitId (thisPackage dflags), + unitPackageVersion = makeVersion [], + unitId = toUnitId (thisPackage dflags), unitComponentName = Nothing, unitInstanceOf = cid, unitInstantiations = insts, @@ -327,8 +327,8 @@ buildUnit session cid insts lunit = do -- really used for anything, so we leave it -- blank for now. TcSession -> [] - _ -> map (toInstalledUnitId . unwireUnitId dflags) - $ deps ++ [ moduleUnitId mod + _ -> map (toUnitId . unwireUnit dflags) + $ deps ++ [ moduleUnit mod | (_, mod) <- insts , not (isHoleModule mod) ], unitAbiDepends = [], @@ -391,21 +391,18 @@ addPackage pkg = do _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) }) return () --- Precondition: UnitId is NOT InstalledUnitId -compileInclude :: Int -> (Int, UnitId) -> BkpM () +compileInclude :: Int -> (Int, Unit) -> BkpM () compileInclude n (i, uid) = do hsc_env <- getSession let dflags = hsc_dflags hsc_env msgInclude (i, n) uid -- Check if we've compiled it already - case lookupUnit dflags uid of - Nothing -> do - case splitUnitIdInsts uid of - (_, Just indef) -> - innerBkpM $ compileUnit (indefUnitIdComponentId indef) - (indefUnitIdInsts indef) - _ -> return () - Just _ -> return () + case uid of + HoleUnit -> return () + RealUnit _ -> return () + VirtUnit i -> case lookupUnit dflags uid of + Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i) + Just _ -> return () -- ---------------------------------------------------------------------------- -- Backpack monad @@ -423,7 +420,7 @@ data BkpEnv -- | The filename of the bkp file we're compiling bkp_filename :: FilePath, -- | Table of source units which we know how to compile - bkp_table :: Map ComponentId (LHsUnit HsComponentId), + bkp_table :: Map IndefUnitId (LHsUnit HsComponentId), -- | When a package we are compiling includes another package -- which has not been compiled, we bump the level and compile -- that. @@ -535,7 +532,7 @@ msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn -- | Message when we instantiate a Backpack unit. -msgUnitId :: UnitId -> BkpM () +msgUnitId :: Unit -> BkpM () msgUnitId pk = do dflags <- getDynFlags level <- getBkpLevel @@ -545,7 +542,7 @@ msgUnitId pk = do (ppr pk) -- | Message when we include a Backpack unit. -msgInclude :: (Int,Int) -> UnitId -> BkpM () +msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do dflags <- getDynFlags level <- getBkpLevel @@ -563,7 +560,7 @@ type PackageNameMap a = Map PackageName a -- to use this for anything unitDefines :: PackageState -> LHsUnit PackageName -> (PackageName, HsComponentId) unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) - = (pn, HsComponentId pn (mkComponentId pkgstate fs)) + = (pn, HsComponentId pn (mkIndefUnitId pkgstate fs)) packageNameMap :: PackageState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId packageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units) @@ -609,16 +606,16 @@ renameHsUnits pkgstate m units = map (fmap renameHsUnit) units renameHsModuleId (HsModuleVar lm) = HsModuleVar lm renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm -convertHsUnitId :: HsUnitId HsComponentId -> UnitId -convertHsUnitId (HsUnitId (L _ hscid) subst) - = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) +convertHsComponentId :: HsUnitId HsComponentId -> Unit +convertHsComponentId (HsUnitId (L _ hscid) subst) + = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module) convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m) convertHsModuleId :: HsModuleId HsComponentId -> Module convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname -convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname +convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname @@ -824,8 +821,7 @@ hsModuleToModSummary pn hsc_src modname -- | Create a new, externally provided hashed unit id from -- a hash. -newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId -newInstalledUnitId (ComponentId cid_fs _) (Just fs) - = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs) -newInstalledUnitId (ComponentId cid_fs _) Nothing - = InstalledUnitId cid_fs +newUnitId :: IndefUnitId -> Maybe FastString -> UnitId +newUnitId uid mhash = case mhash of + Nothing -> indefUnit uid + Just hash -> UnitId (unitIdFS (indefUnit uid) `appendFS` mkFastString "+" `appendFS` hash) diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs index bb459d8e35..e579fe42a1 100644 --- a/compiler/GHC/Driver/Backpack/Syntax.hs +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -35,7 +35,7 @@ import GHC.Unit.Info data HsComponentId = HsComponentId { hsPackageName :: PackageName, - hsComponentId :: ComponentId + hsComponentId :: IndefUnitId } instance Outputable HsComponentId where diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index cba5d1b644..446deb2c99 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -60,7 +60,7 @@ codeOutput :: DynFlags -> ForeignStubs -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with with the C compiler - -> [InstalledUnitId] + -> [UnitId] -> Stream IO RawCmmGroup a -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), @@ -120,7 +120,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action outputC :: DynFlags -> FilePath -> Stream IO RawCmmGroup a - -> [InstalledUnitId] + -> [UnitId] -> IO a outputC dflags filenm cmm_stream packages @@ -133,7 +133,7 @@ outputC dflags filenm cmm_stream packages -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. -- - let rts = getPackageDetails dflags rtsUnitId + let rts = unsafeGetUnitInfo dflags rtsUnitId let cc_injects = unlines (map mk_include (unitIncludes rts)) mk_include h_file = @@ -142,7 +142,7 @@ outputC dflags filenm cmm_stream packages '<':_ -> "#include "++h_file _ -> "#include \""++h_file++"\"" - let pkg_names = map installedUnitIdString packages + let pkg_names = map unitIdString packages doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") @@ -225,7 +225,7 @@ outputForeignStubs dflags mod location stubs -- we need the #includes from the rts package for the stub files let rts_includes = - let rts_pkg = getPackageDetails dflags rtsUnitId in + let rts_pkg = unsafeGetUnitInfo dflags rtsUnitId in concatMap mk_include (unitIncludes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs index 5eb00e6dd2..1b50d280a6 100644 --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} module GHC.Driver.Finder ( flushFinderCaches, @@ -76,7 +77,7 @@ flushFinderCaches hsc_env = where this_pkg = thisPackage (hsc_dflags hsc_env) fc_ref = hsc_FC hsc_env - is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True + is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True | otherwise = False addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () @@ -135,8 +136,8 @@ findPluginModule hsc_env mod_name = findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env - in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags - then findInstalledHomeModule hsc_env (installedModuleName mod) + in if moduleUnit mod `unitIdEq` thisPackage dflags + then findInstalledHomeModule hsc_env (moduleName mod) else findPackageModule hsc_env mod -- ----------------------------------------------------------------------------- @@ -194,7 +195,7 @@ findExposedPluginPackageModule hsc_env mod_name findLookupResult :: HscEnv -> LookupResult -> IO FindResult findLookupResult hsc_env r = case r of LookupFound m pkg_conf -> do - let im = fst (splitModuleInsts m) + let im = fst (getModuleInstantiation m) r' <- findPackageModule_ hsc_env im pkg_conf case r' of -- TODO: ghc -M is unlikely to do the right thing @@ -202,8 +203,8 @@ findLookupResult hsc_env r = case r of -- instantiated; you probably also need all of the -- implicit locations from the instances InstalledFound loc _ -> return (Found loc m) - InstalledNoPackage _ -> return (NoPackage (moduleUnitId m)) - InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m) + InstalledNoPackage _ -> return (NoPackage (moduleUnit m)) + InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m) , fr_pkgs_hidden = [] , fr_mods_hidden = [] , fr_unusables = [] @@ -212,13 +213,13 @@ findLookupResult hsc_env r = case r of return (FoundMultiple rs) LookupHidden pkg_hiddens mod_hiddens -> return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens - , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens + , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens , fr_unusables = [] , fr_suggestions = [] }) LookupUnusable unusable -> let unusables' = map get_unusable unusable - get_unusable (m, ModUnusable r) = (moduleUnitId m, r) + get_unusable (m, ModUnusable r) = (moduleUnit m, r) get_unusable (_, r) = pprPanic "findLookupResult: unexpected origin" (ppr r) in return (NotFound{ fr_paths = [], fr_pkg = Nothing @@ -245,8 +246,8 @@ modLocationCache hsc_env mod do_this = do mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule mkHomeInstalledModule dflags mod_name = - let iuid = thisInstalledUnitId dflags - in InstalledModule iuid mod_name + let iuid = thisUnitId dflags + in Module iuid mod_name -- This returns a module because it's more convenient for users addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module @@ -339,7 +340,7 @@ findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env - pkg_id = installedModuleUnitId mod + pkg_id = moduleUnit mod pkgstate = pkgState dflags -- case lookupInstalledPackage pkgstate pkg_id of @@ -355,7 +356,7 @@ findPackageModule hsc_env mod = do -- for the appropriate config. findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult findPackageModule_ hsc_env mod pkg_conf = - ASSERT2( installedModuleUnitId mod == installedUnitInfoId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedUnitInfoId pkg_conf) ) + ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) ) modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. @@ -381,7 +382,7 @@ findPackageModule_ hsc_env mod pkg_conf = [one] | MkDepend <- ghcMode dflags -> do -- there's only one place that this .hi file can be, so -- don't bother looking for it. - let basename = moduleNameSlashes (installedModuleName mod) + let basename = moduleNameSlashes (moduleName mod) loc <- mk_hi_loc one basename return (InstalledFound loc mod) _otherwise -> @@ -413,7 +414,7 @@ searchPathExts paths mod exts return result where - basename = moduleNameSlashes (installedModuleName mod) + basename = moduleNameSlashes (moduleName mod) to_search :: [(FilePath, IO ModLocation)] to_search = [ (file, fn path basename) @@ -424,7 +425,7 @@ searchPathExts paths mod exts file = base <.> ext ] - search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod))) + search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod))) search ((file, mk_result) : rest) = do b <- doesFileExist file @@ -649,7 +650,7 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) where unambiguousPackages = foldl' unambiguousPackage (Just []) mods unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (moduleUnitId m : xs) + = Just (moduleUnit m : xs) unambiguousPackage _ _ = Nothing pprMod (m, o) = text "it is bound as" <+> ppr m <+> @@ -658,10 +659,10 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( if e == Just True - then [text "package" <+> ppr (moduleUnitId m)] + then [text "package" <+> ppr (moduleUnit m)] else [] ++ map ((text "a reexport in package" <+>) - .ppr.packageConfigId) res ++ + .ppr.mkUnit) res ++ if f then [text "a package flag"] else [] ) @@ -714,7 +715,7 @@ cantFindErr cannot_find _ dflags mod_name find_result text "try running 'ghc-pkg check'." $$ tried_these files dflags - pkg_hidden :: UnitId -> SDoc + pkg_hidden :: Unit -> SDoc pkg_hidden uid = text "It is a member of the hidden package" <+> quotes (ppr uid) @@ -758,11 +759,11 @@ cantFindErr cannot_find _ dflags mod_name find_result fromExposedReexport = res, fromPackageFlag = f }) | Just True <- e - = parens (text "from" <+> ppr (moduleUnitId mod)) + = parens (text "from" <+> ppr (moduleUnit mod)) | f && moduleName mod == m - = parens (text "from" <+> ppr (moduleUnitId mod)) + = parens (text "from" <+> ppr (moduleUnit mod)) | (pkg:_) <- res - = parens (text "from" <+> ppr (packageConfigId pkg) + = parens (text "from" <+> ppr (mkUnit pkg) <> comma <+> text "reexporting" <+> ppr mod) | f = parens (text "defined via package flags to be" @@ -775,10 +776,10 @@ cantFindErr cannot_find _ dflags mod_name find_result fromHiddenReexport = rhs }) | Just False <- e = parens (text "needs flag -package-key" - <+> ppr (moduleUnitId mod)) + <+> ppr (moduleUnit mod)) | (pkg:_) <- rhs = parens (text "needs flag -package-id" - <+> ppr (packageConfigId pkg)) + <+> ppr (mkUnit pkg)) | otherwise = Outputable.empty cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName @@ -794,7 +795,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 `installedUnitIdEq` thisPackage dflags) + | Just pkg <- mb_pkg, not (pkg `unitIdEq` thisPackage dflags) -> not_found_in_package pkg files | null files @@ -808,13 +809,13 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result build_tag = buildTag dflags pkgstate = pkgState dflags - looks_like_srcpkgid :: InstalledUnitId -> SDoc + 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 (installedUnitIdFS pk)) + | (pkg:pkgs) <- searchPackageId pkgstate (PackageId (unitIdFS pk)) = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$ + text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ (if null pkgs then Outputable.empty else text "and" <+> int (length pkgs) <+> text "other candidates")) -- Todo: also check if it looks like a package name! diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index d5c5cfedbc..c62b40cf0d 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -475,7 +475,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do 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( moduleUnitId outer_mod == thisPackage dflags ) + MASSERT( moduleUnit outer_mod == thisPackage dflags ) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc else @@ -1049,7 +1049,7 @@ checkSafeImports tcg_env imports = imp_mods impInfo -- ImportedMods imports1 = moduleEnvToList imports -- (Module, [ImportedBy]) imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) - pkgReqs = imp_trust_pkgs impInfo -- [UnitId] + pkgReqs = imp_trust_pkgs impInfo -- [Unit] condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!" @@ -1069,11 +1069,11 @@ checkSafeImports tcg_env = return v1 -- easier interface to work with - checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId) + checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId) checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l -- what pkg's to add to our trust requirements - pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId -> + pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> Bool -> ImportAvails pkgTrustReqs dflags req inf infPassed | safeInferOn dflags && not (safeHaskellModeEnabled dflags) && infPassed @@ -1097,7 +1097,7 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyBag errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) hscGetSafe hsc_env m l = runHsc hsc_env $ do (self, pkgs) <- hscCheckSafe' m l good <- isEmptyBag `fmap` getWarnings @@ -1111,7 +1111,7 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. hscCheckSafe' :: Module -> SrcSpan - -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId) + -> Hsc (Maybe UnitId, Set UnitId) hscCheckSafe' m l = do dflags <- getDynFlags (tw, pkgs) <- isModSafe m l @@ -1120,9 +1120,9 @@ hscCheckSafe' m l = do True | isHomePkg dflags 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 $ toInstalledUnitId (moduleUnitId m), pkgs) + | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) where - isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId) + isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set UnitId) isModSafe m l = do dflags <- getDynFlags iface <- lookup' m @@ -1170,7 +1170,7 @@ hscCheckSafe' m l = do pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" - , text "The package (" <> ppr (moduleUnitId m) + , text "The package (" <> ppr (moduleUnit m) <> text ") the module resides in isn't trusted." ] modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ @@ -1192,7 +1192,7 @@ hscCheckSafe' m l = do packageTrusted _ Sf_SafeInferred False _ = True packageTrusted dflags _ _ m | isHomePkg dflags m = True - | otherwise = unitIsTrusted $ getPackageDetails dflags (moduleUnitId m) + | otherwise = unitIsTrusted $ unsafeGetUnitInfo dflags (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do @@ -1212,11 +1212,11 @@ hscCheckSafe' m l = do isHomePkg :: DynFlags -> Module -> Bool isHomePkg dflags m - | thisPackage dflags == moduleUnitId m = True + | thisPackage dflags == moduleUnit m = True | otherwise = False -- | Check the list of packages are trusted. -checkPkgTrust :: Set InstalledUnitId -> Hsc () +checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do dflags <- getDynFlags let errors = S.foldr go [] pkgs diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index dd8d0a217f..866d1a080b 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -309,9 +309,9 @@ warnUnusedPackages = do pit = eps_PIT eps let loadedPackages - = map (getPackageDetails dflags) + = map (unsafeGetUnitInfo dflags) . nub . sort - . map moduleUnitId + . map moduleUnit . moduleEnvKeys $ pit @@ -348,16 +348,16 @@ warnUnusedPackages = do matching :: DynFlags -> PackageArg -> UnitInfo -> Bool matching _ (PackageArg str) p = matchingStr str p - matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p + matching dflags (UnitIdArg uid) p = uid == realUnit dflags p -- For wired-in packages, we have to unwire their id, -- otherwise they won't match package flags - realUnitId :: DynFlags -> UnitInfo -> UnitId - realUnitId dflags - = unwireUnitId dflags - . DefiniteUnitId - . DefUnitId - . installedUnitInfoId + realUnit :: DynFlags -> UnitInfo -> Unit + realUnit dflags + = unwireUnit dflags + . RealUnit + . Definite + . unitId -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally @@ -965,7 +965,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do hsc_env <- getSession let dflags = hsc_dflags hsc_env - when (not (null (unitIdsToCheck dflags))) $ + when (not (null (instantiatedUnitsToCheck dflags))) $ throwGhcException (ProgramError "Backpack typechecking not supported with -j") -- The bits of shared state we'll be using: @@ -1374,7 +1374,7 @@ upsweep upsweep mHscMessage old_hpt stable_mods cleanup sccs = do dflags <- getSessionDynFlags (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) - (unitIdsToCheck dflags) done_holes + (instantiatedUnitsToCheck dflags) done_holes return (res, reverse $ mgModSummaries done) where done_holes = emptyUniqSet @@ -1405,13 +1405,13 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do -> [SCC ModSummary] -> Int -> Int - -> [UnitId] + -> [Unit] -> UniqSet ModuleName -> m (SuccessFlag, ModuleGraph) upsweep' _old_hpt done [] _ _ uids_to_check _ = do hsc_env <- getSession - liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) uids_to_check return (Succeeded, done) upsweep' _old_hpt done @@ -1436,13 +1436,13 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do -- our imports when you run --make. let (ready_uids, uids_to_check') = partition (\uid -> isEmptyUniqDSet - (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes)) + (unitFreeModuleHoles uid `uniqDSetMinusUniqSet` done_holes)) uids_to_check done_holes' | ms_hsc_src mod == HsigFile = addOneToUniqSet done_holes (ms_mod_name mod) | otherwise = done_holes - liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) ready_uids -- Remove unwanted tmp files between compilations liftIO (cleanup hsc_env) @@ -1517,16 +1517,17 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' -unitIdsToCheck :: DynFlags -> [UnitId] -unitIdsToCheck dflags = - nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags)) +-- | Return a list of instantiated units to type check from the PackageState. +-- +-- Use explicit (instantiated) units as roots and also return their +-- instantiations that are themselves instantiations and so on recursively. +instantiatedUnitsToCheck :: DynFlags -> [Unit] +instantiatedUnitsToCheck dflags = + nubSort $ concatMap goUnit (explicitPackages (pkgState dflags)) where - goUnitId uid = - case splitUnitIdInsts uid of - (_, Just indef) -> - let insts = indefUnitIdInsts indef - in uid : concatMap (goUnitId . moduleUnitId . snd) insts - _ -> [] + goUnit HoleUnit = [] + goUnit (RealUnit _) = [] + goUnit uid@(VirtUnit i) = uid : concatMap (goUnit . moduleUnit . snd) (instUnitInsts i) maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) maybeGetIfaceDate dflags location diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs index 2f0a8b46d4..c6dac71e06 100644 --- a/compiler/GHC/Driver/Packages.hs +++ b/compiler/GHC/Driver/Packages.hs @@ -7,7 +7,7 @@ module GHC.Driver.Packages ( module GHC.Unit.Info, -- * Reading the package config, and processing cmdline args - PackageState(preloadPackages, explicitPackages, moduleNameProvidersMap, requirementContext), + PackageState(..), PackageDatabase (..), UnitInfoMap, emptyPackageState, @@ -23,12 +23,11 @@ module GHC.Driver.Packages ( lookupUnit', lookupInstalledPackage, lookupPackageName, - improveUnitId, + improveUnit, searchPackageId, - getPackageDetails, + unsafeGetUnitInfo, getInstalledPackageDetails, - componentIdString, - displayInstalledUnitId, + displayUnitId, listVisibleModuleNames, lookupModuleInAllPackages, lookupModuleWithSuggestions, @@ -55,9 +54,9 @@ module GHC.Driver.Packages ( packageHsLibs, getLibs, -- * Utils - mkComponentId, - updateComponentId, - unwireUnitId, + mkIndefUnitId, + updateIndefUnitId, + unwireUnit, pprFlag, pprPackages, pprPackagesSimple, @@ -105,7 +104,6 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Map as Map import qualified Data.Map.Strict as MapStrict import qualified Data.Set as Set -import Data.Version -- --------------------------------------------------------------------------- -- The Package state @@ -194,11 +192,11 @@ instance Outputable ModuleOrigin where (if null res then [] else [text "reexport by" <+> - sep (map (ppr . packageConfigId) res)]) ++ + sep (map (ppr . mkUnit) res)]) ++ (if null rhs then [] else [text "hidden reexport by" <+> - sep (map (ppr . packageConfigId) res)]) ++ + sep (map (ppr . mkUnit) res)]) ++ (if f then [text "package flag"] else []) )) @@ -245,24 +243,25 @@ originEmpty :: ModuleOrigin -> Bool originEmpty (ModOrigin Nothing [] [] False) = True originEmpty _ = False --- | 'UniqFM' map from 'InstalledUnitId' -type InstalledUnitIdMap = UniqDFM - --- | 'UniqFM' map from 'UnitId' to 'UnitInfo', plus --- the transitive closure of preload packages. -data UnitInfoMap = UnitInfoMap { - unUnitInfoMap :: InstalledUnitIdMap UnitInfo, - -- | The set of transitively reachable packages according - -- to the explicitly provided command line arguments. - -- See Note [UnitId to InstalledUnitId improvement] - preloadClosure :: UniqSet InstalledUnitId - } +-- | Map from 'UnitId' to 'UnitInfo', plus +-- the transitive closure of preload units. +data UnitInfoMap = UnitInfoMap + { unUnitInfoMap :: UniqDFM UnitInfo + -- ^ Map from 'UnitId' to 'UnitInfo' + + , preloadClosure :: UniqSet UnitId + -- ^ The set of transitively reachable units according + -- to the explicitly provided command line arguments. + -- A fully instantiated VirtUnit may only be replaced by a RealUnit from + -- this set. + -- See Note [VirtUnit to RealUnit improvement] + } --- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. -type VisibilityMap = Map UnitId UnitVisibility +-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. +type VisibilityMap = Map Unit UnitVisibility -- | 'UnitVisibility' records the various aspects of visibility of a particular --- 'UnitId'. +-- 'Unit'. data UnitVisibility = UnitVisibility { uv_expose_all :: Bool -- ^ Should all modules in exposed-modules should be dumped into scope? @@ -270,10 +269,10 @@ data UnitVisibility = UnitVisibility -- ^ Any custom renamings that should bring extra 'ModuleName's into -- scope. , uv_package_name :: First FastString - -- ^ The package name is associated with the 'UnitId'. This is used + -- ^ The package name associated with the 'Unit'. This is used -- to implement legacy behavior where @-package foo-0.1@ implicitly -- hides any packages named @foo@ - , uv_requirements :: Map ModuleName (Set IndefModule) + , uv_requirements :: Map ModuleName (Set InstantiatedModule) -- ^ The signatures which are contributed to the requirements context -- from this unit ID. , uv_explicit :: Bool @@ -312,7 +311,7 @@ instance Monoid UnitVisibility where mappend = (Semigroup.<>) type WiredUnitId = DefUnitId -type PreloadUnitId = InstalledUnitId +type PreloadUnitId = UnitId -- | Map from 'ModuleName' to a set of of module providers (i.e. a 'Module' and -- its 'ModuleOrigin'). @@ -323,16 +322,16 @@ type ModuleNameProvidersMap = Map ModuleName (Map Module ModuleOrigin) data PackageState = PackageState { - -- | A mapping of 'UnitId' to 'UnitInfo'. This list is adjusted + -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted -- so that only valid packages are here. 'UnitInfo' reflects -- what was stored *on disk*, except for the 'trusted' flag, which -- is adjusted at runtime. (In particular, some packages in this map -- may have the 'exposed' flag be 'False'.) unitInfoMap :: UnitInfoMap, - -- | A mapping of 'PackageName' to 'ComponentId'. This is used when + -- | A mapping of 'PackageName' to 'IndefUnitId'. This is used when -- users refer to packages in Backpack includes. - packageNameMap :: Map PackageName ComponentId, + packageNameMap :: Map PackageName IndefUnitId, -- | A mapping from wired in names to the original names from the -- package database. @@ -345,7 +344,7 @@ data PackageState = PackageState { -- | Packages which we explicitly depend on (from a command line flag). -- We'll use this to generate version macros. - explicitPackages :: [UnitId], + explicitPackages :: [Unit], -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want @@ -362,7 +361,7 @@ data PackageState = PackageState { -- and @r[C=<A>]:C@. -- -- There's an entry in this map for each hole in our home library. - requirementContext :: Map ModuleName [IndefModule] + requirementContext :: Map ModuleName [InstantiatedModule] } emptyPackageState :: PackageState @@ -378,47 +377,46 @@ emptyPackageState = PackageState { } -- | Package database -data PackageDatabase = PackageDatabase +data PackageDatabase unit = PackageDatabase { packageDatabasePath :: FilePath - , packageDatabaseUnits :: [UnitInfo] + , packageDatabaseUnits :: [GenUnitInfo unit] } -type InstalledPackageIndex = Map InstalledUnitId UnitInfo +type InstalledPackageIndex = Map UnitId UnitInfo -- | Empty package configuration map emptyUnitInfoMap :: UnitInfoMap emptyUnitInfoMap = UnitInfoMap emptyUDFM emptyUniqSet -- | Find the unit we know about with the given unit id, if any -lookupUnit :: DynFlags -> UnitId -> Maybe UnitInfo +lookupUnit :: DynFlags -> Unit -> Maybe UnitInfo lookupUnit dflags = lookupUnit' (isIndefinite dflags) (unitInfoMap (pkgState dflags)) -- | A more specialized interface, which takes a boolean specifying -- whether or not to look for on-the-fly renamed interfaces, and -- just a 'UnitInfoMap' rather than a 'DynFlags' (so it can -- be used while we're initializing 'DynFlags' -lookupUnit' :: Bool -> UnitInfoMap -> UnitId -> Maybe UnitInfo -lookupUnit' False (UnitInfoMap pkg_map _) uid = lookupUDFM pkg_map uid -lookupUnit' True m@(UnitInfoMap pkg_map _) uid = - case splitUnitIdInsts uid of - (iuid, Just indef) -> - fmap (renamePackage m (indefUnitIdInsts indef)) - (lookupUDFM pkg_map iuid) - (_, Nothing) -> lookupUDFM pkg_map uid +lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo +lookupUnit' False (UnitInfoMap pkg_map _) uid = lookupUDFM pkg_map uid +lookupUnit' True m@(UnitInfoMap pkg_map _) uid = case uid of + HoleUnit -> error "Hole unit" + RealUnit _ -> lookupUDFM pkg_map uid + VirtUnit i -> fmap (renamePackage m (instUnitInsts i)) + (lookupUDFM pkg_map (instUnitInstanceOf i)) {- --- | Find the indefinite package for a given 'ComponentId'. +-- | Find the indefinite package for a given 'IndefUnitId'. -- The way this works is just by fiat'ing that every indefinite package's -- unit key is precisely its component ID; and that they share uniques. -lookupComponentId :: PackageState -> ComponentId -> Maybe UnitInfo -lookupComponentId pkgstate (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs +lookupIndefUnitId :: PackageState -> IndefUnitId -> Maybe UnitInfo +lookupIndefUnitId pkgstate (IndefUnitId cid_fs) = lookupUDFM pkg_map cid_fs where UnitInfoMap pkg_map = unitInfoMap pkgstate -} -- | Find the package we know about with the given package name (e.g. @foo@), if any -- (NB: there might be a locally defined unit name which overrides this) -lookupPackageName :: PackageState -> PackageName -> Maybe ComponentId +lookupPackageName :: PackageState -> PackageName -> Maybe IndefUnitId lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate) -- | Search for packages with a given package ID (e.g. \"foo-0.1\") @@ -431,26 +429,26 @@ extendUnitInfoMap :: UnitInfoMap -> [UnitInfo] -> UnitInfoMap extendUnitInfoMap (UnitInfoMap pkg_map closure) new_pkgs = UnitInfoMap (foldl' add pkg_map new_pkgs) closure - -- We also add the expanded version of the packageConfigId, so that - -- 'improveUnitId' can find it. + -- We also add the expanded version of the mkUnit, so that + -- 'improveUnit' can find it. where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedUnitInfoId p) p) - (installedUnitInfoId p) p + (unitId p) p -- | Looks up the package with the given id in the package state, panicing if it is -- not found -getPackageDetails :: HasDebugCallStack => DynFlags -> UnitId -> UnitInfo -getPackageDetails dflags pid = +unsafeGetUnitInfo :: HasDebugCallStack => DynFlags -> Unit -> UnitInfo +unsafeGetUnitInfo dflags pid = case lookupUnit dflags pid of Just config -> config - Nothing -> pprPanic "getPackageDetails" (ppr pid) + Nothing -> pprPanic "unsafeGetUnitInfo" (ppr pid) -lookupInstalledPackage :: PackageState -> InstalledUnitId -> Maybe UnitInfo +lookupInstalledPackage :: PackageState -> UnitId -> Maybe UnitInfo lookupInstalledPackage pkgstate uid = lookupInstalledPackage' (unitInfoMap pkgstate) uid -lookupInstalledPackage' :: UnitInfoMap -> InstalledUnitId -> Maybe UnitInfo +lookupInstalledPackage' :: UnitInfoMap -> UnitId -> Maybe UnitInfo lookupInstalledPackage' (UnitInfoMap db _) uid = lookupUDFM db uid -getInstalledPackageDetails :: HasDebugCallStack => PackageState -> InstalledUnitId -> UnitInfo +getInstalledPackageDetails :: HasDebugCallStack => PackageState -> UnitId -> UnitInfo getInstalledPackageDetails pkgstate uid = case lookupInstalledPackage pkgstate uid of Just config -> config @@ -508,7 +506,7 @@ initPackages dflags = withTiming dflags -- ----------------------------------------------------------------------------- -- Reading the package database(s) -readPackageDatabases :: DynFlags -> IO [PackageDatabase] +readPackageDatabases :: DynFlags -> IO [PackageDatabase UnitId] readPackageDatabases dflags = do conf_refs <- getPackageConfRefs dflags confs <- liftM catMaybes $ mapM (resolvePackageDatabase dflags) conf_refs @@ -564,7 +562,7 @@ resolvePackageDatabase dflags UserPkgDb = runMaybeT $ do if exist then return pkgconf else mzero resolvePackageDatabase _ (PkgDbPath name) = return $ Just name -readPackageDatabase :: DynFlags -> FilePath -> IO PackageDatabase +readPackageDatabase :: DynFlags -> FilePath -> IO (PackageDatabase UnitId) readPackageDatabase dflags conf_file = do isdir <- doesDirectoryExist conf_file @@ -591,7 +589,7 @@ readPackageDatabase dflags conf_file = do conf_file' = dropTrailingPathSeparator conf_file top_dir = topDir dflags pkgroot = takeDirectory conf_file' - pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . toUnitInfo) + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) unitIdFS . mkUnitKeyInfo) proto_pkg_configs -- return $ PackageDatabase conf_file' pkg_configs1 @@ -694,7 +692,7 @@ applyTrustFlag dflags prec_map unusable pkgs flag = -- | A little utility to tell if the 'thisPackage' is indefinite -- (if it is not, we should never use on-the-fly renaming.) isIndefinite :: DynFlags -> Bool -isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags)) +isIndefinite dflags = not (unitIsDefinite (thisPackage dflags)) applyPackageFlag :: DynFlags @@ -725,19 +723,18 @@ applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid | otherwise = Map.empty - collectHoles uid = case splitUnitIdInsts uid of - (_, Just indef) -> + collectHoles uid = case uid of + HoleUnit -> Map.empty + RealUnit {} -> Map.empty -- definite units don't have holes + VirtUnit indef -> let local = [ Map.singleton (moduleName mod) - (Set.singleton $ IndefModule indef mod_name) - | (mod_name, mod) <- indefUnitIdInsts indef + (Set.singleton $ Module indef mod_name) + | (mod_name, mod) <- instUnitInsts indef , isHoleModule mod ] - recurse = [ collectHoles (moduleUnitId mod) - | (_, mod) <- indefUnitIdInsts indef ] + recurse = [ collectHoles (moduleUnit mod) + | (_, mod) <- instUnitInsts indef ] in Map.unionsWith Set.union $ local ++ recurse - -- Other types of unit identities don't have holes - (_, Nothing) -> Map.empty - uv = UnitVisibility { uv_expose_all = b @@ -746,7 +743,7 @@ applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = , uv_requirements = reqs , uv_explicit = True } - vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared + vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` -- (or if p-0.1 was registered in the pkgdb as exposed: True), -- the second package flag would override the first one and you @@ -771,7 +768,7 @@ applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = -- NB: renamings never clear | (_:_) <- rns = vm | otherwise = Map.filterWithKey - (\k uv -> k == packageConfigId p + (\k uv -> k == mkUnit p || First (Just n) /= uv_package_name uv) vm _ -> panic "applyPackageFlag" @@ -779,7 +776,7 @@ applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps Right ps -> return vm' - where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps) + where vm' = foldl' (flip Map.delete) vm (map mkUnit ps) -- | Like 'selectPackages', but doesn't return a list of unmatched -- packages. Furthermore, any packages it returns are *renamed* @@ -801,12 +798,14 @@ findPackages prec_map pkg_db arg pkgs unusable then Just p else Nothing finder (UnitIdArg uid) p - = let (iuid, mb_indef) = splitUnitIdInsts uid - in if iuid == installedUnitInfoId p - then Just (case mb_indef of - Nothing -> p - Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p) - else Nothing + = case uid of + RealUnit (Definite iuid) + | iuid == unitId p + -> Just p + VirtUnit inst + | indefUnit (instUnitInstanceOf inst) == unitId p + -> Just (renamePackage pkg_db (instUnitInsts inst) p) + _ -> Nothing selectPackages :: PackagePrecedenceIndex -> PackageArg -> [UnitInfo] -> UnusablePackages @@ -840,12 +839,12 @@ matchingStr str p = str == unitPackageIdString p || str == unitPackageNameString p -matchingId :: InstalledUnitId -> UnitInfo -> Bool -matchingId uid p = uid == installedUnitInfoId p +matchingId :: UnitId -> UnitInfo -> Bool +matchingId uid p = uid == unitId p matching :: PackageArg -> UnitInfo -> Bool matching (PackageArg str) = matchingStr str -matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid +matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case -- | This sorts a list of packages, putting "preferred" packages first. @@ -950,7 +949,7 @@ type WiredInUnitId = String type WiredPackagesMap = Map WiredUnitId WiredUnitId wired_in_unitids :: [WiredInUnitId] -wired_in_unitids = map unitIdString wiredInUnitIds +wired_in_unitids = map unitString wiredInUnitIds findWiredInPackages :: DynFlags @@ -969,7 +968,7 @@ findWiredInPackages dflags prec_map pkgs vis_map = do matches :: UnitInfo -> WiredInUnitId -> Bool pc `matches` pid -- See Note [The integer library] in GHC.Builtin.Names - | pid == unitIdString integerUnitId + | pid == unitString integerUnitId = unitPackageNameString pc `elem` ["integer-gmp", "integer-simple"] pc `matches` pid = unitPackageNameString pc == pid @@ -996,7 +995,7 @@ findWiredInPackages dflags prec_map pkgs vis_map = do let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] all_exposed_ps = [ p | p <- all_ps - , Map.member (packageConfigId p) vis_map ] in + , Map.member (mkUnit p) vis_map ] in case all_exposed_ps of [] -> case all_ps of [] -> notfound @@ -1040,7 +1039,7 @@ findWiredInPackages dflags prec_map pkgs vis_map = do wiredInMap :: Map WiredUnitId WiredUnitId wiredInMap = Map.fromList - [ (key, DefUnitId (stringToInstalledUnitId wiredInUnitId)) + [ (key, Definite (stringToUnitId wiredInUnitId)) | (wiredInUnitId, pkg) <- wired_in_pkgs , Just key <- pure $ definiteUnitInfoId pkg ] @@ -1049,16 +1048,16 @@ findWiredInPackages dflags prec_map pkgs vis_map = do where upd_pkg pkg | Just def_uid <- definiteUnitInfoId pkg , Just wiredInUnitId <- Map.lookup def_uid wiredInMap - = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId) + = let fs = unitIdFS (unDefinite wiredInUnitId) in pkg { - unitId = fsToInstalledUnitId fs, - unitInstanceOf = mkComponentId pkgstate fs + unitId = fsToUnitId fs, + unitInstanceOf = mkIndefUnitId pkgstate fs } | otherwise = pkg upd_deps pkg = pkg { -- temporary harmless DefUnitId invariant violation - unitDepends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (unitDepends pkg), + unitDepends = map (unDefinite . upd_wired_in wiredInMap . Definite) (unitDepends pkg), unitExposedModules = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) (unitExposedModules pkg) @@ -1067,8 +1066,8 @@ findWiredInPackages dflags prec_map pkgs vis_map = do return (updateWiredInDependencies pkgs, wiredInMap) --- Helper functions for rewiring Module and UnitId. These --- rewrite UnitIds of modules in wired-in packages to the form known to the +-- Helper functions for rewiring Module and Unit. These +-- rewrite Units of modules in wired-in packages to the form known to the -- compiler, as described in Note [Wired-in packages] in GHC.Types.Module. -- -- For instance, base-4.9.0.0 will be rewritten to just base, to match @@ -1077,13 +1076,14 @@ findWiredInPackages dflags prec_map pkgs vis_map = do upd_wired_in_mod :: WiredPackagesMap -> Module -> Module upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m -upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId -upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) = - DefiniteUnitId (upd_wired_in wiredInMap def_uid) -upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) = - IndefiniteUnitId $ newIndefUnitId - (indefUnitIdComponentId indef_uid) - (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid)) +upd_wired_in_uid :: WiredPackagesMap -> Unit -> Unit +upd_wired_in_uid wiredInMap u = case u of + HoleUnit -> HoleUnit + RealUnit def_uid -> RealUnit (upd_wired_in wiredInMap def_uid) + VirtUnit indef_uid -> + VirtUnit $ mkInstantiatedUnit + (instUnitInstanceOf indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId upd_wired_in wiredInMap key @@ -1092,10 +1092,10 @@ upd_wired_in wiredInMap key updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) - where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of + where f vm (from, to) = case Map.lookup (RealUnit from) vis_map of Nothing -> vm - Just r -> Map.insert (DefiniteUnitId to) r - (Map.delete (DefiniteUnitId from) vm) + Just r -> Map.insert (RealUnit to) r + (Map.delete (RealUnit from) vm) -- ---------------------------------------------------------------------------- @@ -1106,17 +1106,17 @@ data UnusablePackageReason IgnoredWithFlag -- | This package transitively depends on a package that was never present -- in any of the provided databases. - | BrokenDependencies [InstalledUnitId] + | BrokenDependencies [UnitId] -- | This package transitively depends on a package involved in a cycle. - -- Note that the list of 'InstalledUnitId' reports the direct dependencies + -- Note that the list of 'UnitId' reports the direct dependencies -- of this package that (transitively) depended on the cycle, and not -- the actual cycle itself (which we report separately at high verbosity.) - | CyclicDependencies [InstalledUnitId] + | CyclicDependencies [UnitId] -- | This package transitively depends on a package which was ignored. - | IgnoredDependencies [InstalledUnitId] + | IgnoredDependencies [UnitId] -- | This package transitively depends on a package which was -- shadowed by an ABI-incompatible package. - | ShadowedDependencies [InstalledUnitId] + | ShadowedDependencies [UnitId] instance Outputable UnusablePackageReason where ppr IgnoredWithFlag = text "[ignored with flag]" @@ -1125,7 +1125,7 @@ instance Outputable UnusablePackageReason where ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) -type UnusablePackages = Map InstalledUnitId +type UnusablePackages = Map UnitId (UnitInfo, UnusablePackageReason) pprReason :: SDoc -> UnusablePackageReason -> SDoc @@ -1168,9 +1168,9 @@ reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) -- Utilities on the database -- --- | A reverse dependency index, mapping an 'InstalledUnitId' to --- the 'InstalledUnitId's which have a dependency on it. -type RevIndex = Map InstalledUnitId [InstalledUnitId] +-- | A reverse dependency index, mapping an 'UnitId' to +-- the 'UnitId's which have a dependency on it. +type RevIndex = Map UnitId [UnitId] -- | Compute the reverse dependency index of a package database. reverseDeps :: InstalledPackageIndex -> RevIndex @@ -1179,12 +1179,12 @@ reverseDeps db = Map.foldl' go Map.empty db go r pkg = foldl' (go' (unitId pkg)) r (unitDepends pkg) go' from r to = Map.insertWith (++) to [from] r --- | Given a list of 'InstalledUnitId's to remove, a database, +-- | Given a list of 'UnitId's to remove, a database, -- and a reverse dependency index (as computed by 'reverseDeps'), -- remove those packages, plus any packages which depend on them. -- Returns the pruned database, as well as a list of 'UnitInfo's -- that was removed. -removePackages :: [InstalledUnitId] -> RevIndex +removePackages :: [UnitId] -> RevIndex -> InstalledPackageIndex -> (InstalledPackageIndex, [UnitInfo]) removePackages uids index m = go uids (m,[]) @@ -1203,7 +1203,7 @@ removePackages uids index m = go uids (m,[]) -- that do not exist in the index. depsNotAvailable :: InstalledPackageIndex -> UnitInfo - -> [InstalledUnitId] + -> [UnitId] depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (unitDepends pkg) -- | Given a 'UnitInfo' from some 'InstalledPackageIndex' @@ -1211,7 +1211,7 @@ depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (unitDepend -- that do not exist, OR have mismatching ABIs. depsAbiMismatch :: InstalledPackageIndex -> UnitInfo - -> [InstalledUnitId] + -> [UnitId] depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg where abiMatch (dep_uid, abi) @@ -1244,13 +1244,13 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) -- the command line. We use this mapping to make sure we prefer -- packages that were defined later on the command line, if there -- is an ambiguity. -type PackagePrecedenceIndex = Map InstalledUnitId Int +type PackagePrecedenceIndex = Map UnitId Int -- | Given a list of databases, merge them together, where -- packages with the same unit id in later databases override -- earlier ones. This does NOT check if the resulting database -- makes sense (that's done by 'validateDatabase'). -mergeDatabases :: DynFlags -> [PackageDatabase] +mergeDatabases :: DynFlags -> [PackageDatabase UnitId] -> IO (InstalledPackageIndex, PackagePrecedenceIndex) mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..] where @@ -1269,7 +1269,7 @@ mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..] -- The set of UnitIds which appear in both db and pkgs. These are the -- ones that get overridden. Compute this just to give some -- helpful debug messages at -v2 - override_set :: Set InstalledUnitId + override_set :: Set UnitId override_set = Set.intersection (Map.keysSet db_map) (Map.keysSet pkg_map) @@ -1344,7 +1344,7 @@ mkPackageState :: DynFlags -- initial databases, in the order they were specified on -- the command line (later databases shadow earlier ones) - -> [PackageDatabase] + -> [PackageDatabase UnitId] -> [PreloadUnitId] -- preloaded packages -> IO (PackageState, [PreloadUnitId], -- new packages to preload @@ -1463,8 +1463,8 @@ mkPackageState dflags dbs preload0 = do -- Note: we NEVER expose indefinite packages by -- default, because it's almost assuredly not -- what you want (no mix-in linking has occurred). - if unitIsExposed p && unitIdIsDefinite (packageConfigId p) && mostPreferable p - then Map.insert (packageConfigId p) + if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p + then Map.insert (mkUnit p) UnitVisibility { uv_expose_all = True, uv_renamings = [], @@ -1568,7 +1568,7 @@ mkPackageState dflags dbs preload0 = do $ (basicLinkedPackages ++ preload2) -- Close the preload packages with their dependencies - dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) + dep_preload <- closeDeps dflags pkg_db (zip (map toUnitId preload3) (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let mod_map1 = mkModuleNameProvidersMap dflags pkg_db vis_map @@ -1593,12 +1593,12 @@ mkPackageState dflags dbs preload0 = do let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags) return (pstate, new_dep_preload, new_insts) --- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' +-- | Given a wired-in 'Unit', "unwire" it into the 'Unit' -- that it was recorded as in the package database. -unwireUnitId :: DynFlags -> UnitId -> UnitId -unwireUnitId dflags uid@(DefiniteUnitId def_uid) = - maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags))) -unwireUnitId _ uid = uid +unwireUnit :: DynFlags -> Unit-> Unit +unwireUnit dflags uid@(RealUnit def_uid) = + maybe uid RealUnit (Map.lookup def_uid (unwireMap (pkgState dflags))) +unwireUnit _ uid = uid -- ----------------------------------------------------------------------------- -- | Makes the mapping from module to package info @@ -1635,7 +1635,7 @@ mkModuleNameProvidersMap dflags pkg_db vis_map = vis_map_extended = Map.union vis_map {- preferred -} default_vis default_vis = Map.fromList - [ (packageConfigId pkg, mempty) + [ (mkUnit pkg, mempty) | pkg <- eltsUDFM (unUnitInfoMap pkg_db) -- Exclude specific instantiations of an indefinite -- package @@ -1684,7 +1684,7 @@ mkModuleNameProvidersMap dflags pkg_db vis_map = hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] - pk = packageConfigId pkg + pk = mkUnit pkg unit_lookup uid = lookupUnit' (isIndefinite dflags) pkg_db uid `orElse` pprPanic "unit_lookup" (ppr uid) @@ -1701,7 +1701,7 @@ mkUnusableModuleNameProvidersMap unusables = bindings = exposed ++ hidden origin = ModUnusable reason - pkg_id = packageConfigId pkg + pkg_id = mkUnit pkg exposed = map get_exposed exposed_mods hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] @@ -1725,7 +1725,7 @@ addListTo = foldl' merge where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m -- | Create a singleton module mapping -mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin +mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin mkModMap pkg mod = Map.singleton (mkModule pkg mod) -- ----------------------------------------------------------------------------- @@ -1870,7 +1870,7 @@ lookupModuleInAllPackages dflags m LookupFound a b -> [(a,b)] LookupMultiple rs -> map f rs where f (m,_) = (m, expectJust "lookupModule" (lookupUnit dflags - (moduleUnitId m))) + (moduleUnit m))) _ -> [] -- | The result of performing a lookup @@ -1941,7 +1941,7 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn -> (x:hidden_pkg, hidden_mod, unusable, exposed) unit_lookup p = lookupUnit dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) - mod_unit = unit_lookup . moduleUnitId + mod_unit = unit_lookup . moduleUnit -- Filters out origins which are not associated with the given package -- qualifier. No-op if there is no package qualifier. Test if this @@ -1996,7 +1996,7 @@ getPreloadPackagesAnd dflags pkgids0 = -- Fixes #14525 if isIndefinite dflags then [] - else map (toInstalledUnitId . moduleUnitId . snd) + else map (toUnitId . moduleUnit . snd) (thisUnitIdInsts dflags) state = pkgState dflags pkg_map = unitInfoMap state @@ -2010,8 +2010,8 @@ getPreloadPackagesAnd dflags pkgids0 = -- in reverse dependency order (a package appears before those it depends on). closeDeps :: DynFlags -> UnitInfoMap - -> [(InstalledUnitId, Maybe InstalledUnitId)] - -> IO [InstalledUnitId] + -> [(UnitId, Maybe UnitId)] + -> IO [UnitId] closeDeps dflags pkg_map ps = throwErr dflags (closeDepsErr dflags pkg_map ps) @@ -2023,8 +2023,8 @@ throwErr dflags m closeDepsErr :: DynFlags -> UnitInfoMap - -> [(InstalledUnitId,Maybe InstalledUnitId)] - -> MaybeErr MsgDoc [InstalledUnitId] + -> [(UnitId,Maybe UnitId)] + -> MaybeErr MsgDoc [UnitId] closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps -- internal helper @@ -2050,25 +2050,16 @@ add_package dflags pkg_db ps (p, mb_parent) missingPackageMsg :: Outputable pkgid => pkgid -> SDoc missingPackageMsg p = text "unknown package:" <+> ppr p -missingDependencyMsg :: Maybe InstalledUnitId -> SDoc +missingDependencyMsg :: Maybe UnitId -> SDoc missingDependencyMsg Nothing = Outputable.empty missingDependencyMsg (Just parent) - = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent)) + = space <> parens (text "dependency of" <+> ftext (unitIdFS parent)) -- ----------------------------------------------------------------------------- -componentIdString :: ComponentId -> String -componentIdString (ComponentId raw Nothing) = unpackFS raw -componentIdString (ComponentId _raw (Just details)) = - case componentName details of - Nothing -> componentSourcePkdId details - Just cname -> componentPackageName details - ++ "-" ++ showVersion (componentPackageVersion details) - ++ ":" ++ cname - -- Cabal packages may contain several components (programs, libraries, etc.). -- As far as GHC is concerned, installed package components ("units") are --- identified by an opaque ComponentId string provided by Cabal. As the string +-- identified by an opaque IndefUnitId string provided by Cabal. As the string -- contains a hash, we don't want to display it to users so GHC queries the -- database to retrieve some infos about the original source package (name, -- version, component name). @@ -2078,26 +2069,26 @@ componentIdString (ComponentId _raw (Just details)) = -- Component name is only displayed if it isn't the default library -- -- To do this we need to query the database (cached in DynFlags). We cache --- these details in the ComponentId itself because we don't want to query --- DynFlags each time we pretty-print the ComponentId +-- these details in the IndefUnitId itself because we don't want to query +-- DynFlags each time we pretty-print the IndefUnitId -- -mkComponentId :: PackageState -> FastString -> ComponentId -mkComponentId pkgstate raw = - case lookupInstalledPackage pkgstate (InstalledUnitId raw) of - Nothing -> ComponentId raw Nothing -- we didn't find the unit at all - Just c -> ComponentId raw $ Just $ ComponentDetails +mkIndefUnitId :: PackageState -> FastString -> IndefUnitId +mkIndefUnitId pkgstate raw = + let uid = UnitId raw + in case lookupInstalledPackage pkgstate uid of + Nothing -> Indefinite uid Nothing -- we didn't find the unit at all + Just c -> Indefinite uid $ Just $ UnitPprInfo (unitPackageNameString c) (unitPackageVersion c) ((unpackFS . unPackageName) <$> unitComponentName c) - (unitPackageIdString c) -- | Update component ID details from the database -updateComponentId :: PackageState -> ComponentId -> ComponentId -updateComponentId pkgstate (ComponentId raw _) = mkComponentId pkgstate raw +updateIndefUnitId :: PackageState -> IndefUnitId -> IndefUnitId +updateIndefUnitId pkgstate uid = mkIndefUnitId pkgstate (unitIdFS (indefUnit uid)) -displayInstalledUnitId :: PackageState -> InstalledUnitId -> Maybe String -displayInstalledUnitId pkgstate uid = +displayUnitId :: PackageState -> UnitId -> Maybe String +displayUnitId pkgstate uid = fmap unitPackageIdString (lookupInstalledPackage pkgstate uid) -- | Will the 'Name' come from a dynamically linked package? @@ -2125,7 +2116,7 @@ isDynLinkName platform this_mod name -- I much rather have dynamic TH not supported than the entire Dynamic linking -- not due to a hack. -- Also not sure this would break on Windows anyway. - OSMinGW32 -> moduleUnitId mod /= moduleUnitId this_mod + OSMinGW32 -> moduleUnit mod /= moduleUnit this_mod -- For the other platforms, still perform the hack _ -> mod /= this_mod @@ -2149,7 +2140,7 @@ pprPackagesWith pprIPI pkgstate = -- be different from the package databases (exposure, trust) pprPackagesSimple :: PackageState -> SDoc pprPackagesSimple = pprPackagesWith pprIPI - where pprIPI ipi = let i = installedUnitIdFS (unitId ipi) + where pprIPI ipi = let i = unitIdFS (unitId ipi) e = if unitIsExposed ipi then text "E" else text " " t = if unitIsTrusted ipi then text "T" else text " " in e <> t <> text " " <> ftext i @@ -2162,7 +2153,7 @@ pprModuleMap mod_map = pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc pprEntry m (m',o) - | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) + | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) | otherwise = ppr m' <+> parens (ppr o) fsPackageName :: UnitInfo -> FastString @@ -2170,20 +2161,20 @@ fsPackageName info = fs where PackageName fs = unitPackageName info --- | Given a fully instantiated 'UnitId', improve it into a --- 'InstalledUnitId' if we can find it in the package database. -improveUnitId :: UnitInfoMap -> UnitId -> UnitId -improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit -improveUnitId pkg_map uid = +-- | Given a fully instantiated 'InstnatiatedUnit', improve it into a +-- 'RealUnit' if we can find it in the package database. +improveUnit :: UnitInfoMap -> Unit -> Unit +improveUnit _ uid@(RealUnit _) = uid -- short circuit +improveUnit pkg_map uid = -- Do NOT lookup indefinite ones, they won't be useful! case lookupUnit' False pkg_map uid of Nothing -> uid Just pkg -> -- Do NOT improve if the indefinite unit id is not -- part of the closure unique set. See - -- Note [UnitId to InstalledUnitId improvement] - if installedUnitInfoId pkg `elementOfUniqSet` preloadClosure pkg_map - then packageConfigId pkg + -- Note [VirtUnit to RealUnit improvement] + if unitId pkg `elementOfUniqSet` preloadClosure pkg_map + then mkUnit pkg else uid -- | Retrieve the 'UnitInfoMap' from 'DynFlags'; used diff --git a/compiler/GHC/Driver/Packages.hs-boot b/compiler/GHC/Driver/Packages.hs-boot index eab2ebd60f..368057e2d3 100644 --- a/compiler/GHC/Driver/Packages.hs-boot +++ b/compiler/GHC/Driver/Packages.hs-boot @@ -2,14 +2,15 @@ module GHC.Driver.Packages where import GHC.Prelude import GHC.Data.FastString import {-# SOURCE #-} GHC.Driver.Session (DynFlags) -import {-# SOURCE #-} GHC.Types.Module(ComponentId, UnitId, InstalledUnitId) +import {-# SOURCE #-} GHC.Types.Module(IndefUnitId, Unit, UnitId) data PackageState data UnitInfoMap -data PackageDatabase +data PackageDatabase unit emptyPackageState :: PackageState -componentIdString :: ComponentId -> String -mkComponentId :: PackageState -> FastString -> ComponentId -displayInstalledUnitId :: PackageState -> InstalledUnitId -> Maybe String -improveUnitId :: UnitInfoMap -> UnitId -> UnitId +mkIndefUnitId :: PackageState -> FastString -> IndefUnitId +displayUnitId :: PackageState -> UnitId -> Maybe String +improveUnit :: UnitInfoMap -> Unit -> Unit getUnitInfoMap :: DynFlags -> UnitInfoMap +unitInfoMap :: PackageState -> UnitInfoMap getPackageState :: DynFlags -> PackageState +updateIndefUnitId :: PackageState -> IndefUnitId -> IndefUnitId diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 0f8f52798b..6656b2d98a 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -490,7 +490,7 @@ link' dflags batch_attempt_linking hpt return Succeeded -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool linkingNeeded dflags staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit @@ -1611,13 +1611,13 @@ getLocation src_flavour mod_name = do ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file -getHCFilePackages :: FilePath -> IO [InstalledUnitId] +getHCFilePackages :: FilePath -> IO [UnitId] getHCFilePackages filename = Exception.bracket (openFile filename ReadMode) hClose $ \h -> do l <- hGetLine h case l of '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToInstalledUnitId (words rest)) + return (map stringToUnitId (words rest)) _other -> return [] @@ -1648,10 +1648,10 @@ it is supported by both gcc and clang. Anecdotally nvcc supports -Xlinker, but not -Wl. -} -linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () +linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO () linkBinary' staticLink dflags o_files dep_packages = do let platform = targetPlatform dflags toolSettings' = toolSettings dflags @@ -1908,7 +1908,7 @@ maybeCreateManifest dflags exe_filename | otherwise = return [] -linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () +linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () linkDynLibCheck dflags o_files dep_packages = do when (haveRtsOptsFlags dflags) $ do @@ -1922,7 +1922,7 @@ linkDynLibCheck dflags o_files dep_packages -- | Linking a static lib will not really link anything. It will merely produce -- a static archive of all dependent static libraries. The resulting library -- will still need to be linked with any remaining link flags. -linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () +linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO () linkStaticLib dflags o_files dep_packages = do let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs @@ -2220,7 +2220,7 @@ getGhcVersionPathName dflags = do candidates <- case ghcVersionFile dflags of Just path -> return [path] Nothing -> (map (</> "ghcversion.h")) <$> - (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) + (getPackageIncludePath dflags [toUnitId rtsUnitId]) found <- filterM doesFileExist candidates case found of diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs index 4d4f9eab77..f10dafda27 100644 --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -58,7 +58,7 @@ import GHC.Driver.Session import GHC.Driver.Types import GHC.Driver.Monad import GHC.Driver.Phases -import GHC.Types.Module ( ModuleName, Module(moduleName)) +import GHC.Types.Module import GHC.Utils.Fingerprint import Data.List (sort) import GHC.Utils.Outputable (Outputable(..), text, (<+>)) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index ec217590ff..5c39848a8d 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -246,7 +246,7 @@ import GHC.Types.Module import {-# SOURCE #-} GHC.Driver.Plugins import {-# SOURCE #-} GHC.Driver.Hooks import {-# SOURCE #-} GHC.Builtin.Names ( mAIN ) -import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase, mkComponentId) +import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase, mkIndefUnitId, updateIndefUnitId) import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags import GHC.Driver.Ways @@ -520,8 +520,8 @@ data DynFlags = DynFlags { solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver -- Typically only 1 is needed - thisInstalledUnitId :: InstalledUnitId, -- ^ Target unit-id - thisComponentId_ :: Maybe ComponentId, -- ^ Unit-id to instantiate + thisUnitId :: UnitId, -- ^ Target unit-id + thisComponentId_ :: Maybe IndefUnitId, -- ^ Unit-id to instantiate thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], -- ^ How to instantiate the unit-id above -- ways @@ -626,7 +626,7 @@ data DynFlags = DynFlags { packageEnv :: Maybe FilePath, -- ^ Filepath to the package environment file (if overriding default) - pkgDatabase :: Maybe [PackageDatabase], + pkgDatabase :: Maybe [PackageDatabase UnitId], -- ^ Stack of package databases for the target platform. -- -- A "package database" is a misleading name as it is really a Unit @@ -1088,8 +1088,9 @@ isNoLink _ = False -- is used. data PackageArg = PackageArg String -- ^ @-package@, by 'PackageName' - | UnitIdArg UnitId -- ^ @-package-id@, by 'UnitId' + | UnitIdArg Unit -- ^ @-package-id@, by 'Unit' deriving (Eq, Show) + instance Outputable PackageArg where ppr (PackageArg pn) = text "package" <+> text pn ppr (UnitIdArg uid) = text "unit" <+> ppr uid @@ -1320,7 +1321,7 @@ defaultDynFlags mySettings llvmConfig = reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, - thisInstalledUnitId = toInstalledUnitId mainUnitId, + thisUnitId = toUnitId mainUnitId, thisUnitIdInsts_ = Nothing, thisComponentId_ = Nothing, @@ -1952,16 +1953,16 @@ setOutputHi f d = d { outputHi = f} setJsonLogAction :: DynFlags -> DynFlags setJsonLogAction d = d { log_action = jsonLogAction } -thisComponentId :: DynFlags -> ComponentId +thisComponentId :: DynFlags -> IndefUnitId thisComponentId dflags = let pkgstate = pkgState dflags in case thisComponentId_ dflags of - Just (ComponentId raw _) -> mkComponentId pkgstate raw + Just uid -> updateIndefUnitId pkgstate uid Nothing -> case thisUnitIdInsts_ dflags of Just _ -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") - Nothing -> mkComponentId pkgstate (unitIdFS (thisPackage dflags)) + Nothing -> mkIndefUnitId pkgstate (unitFS (thisPackage dflags)) thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] thisUnitIdInsts dflags = @@ -1969,36 +1970,36 @@ thisUnitIdInsts dflags = Just insts -> insts Nothing -> [] -thisPackage :: DynFlags -> UnitId +thisPackage :: DynFlags -> Unit thisPackage dflags = case thisUnitIdInsts_ dflags of Nothing -> default_uid Just insts | all (\(x,y) -> mkHoleModule x == y) insts - -> newUnitId (thisComponentId dflags) insts + -> mkVirtUnit (thisComponentId dflags) insts | otherwise -> default_uid where - default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags)) + default_uid = RealUnit (Definite (thisUnitId dflags)) -parseUnitIdInsts :: String -> [(ModuleName, Module)] -parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of +parseUnitInsts :: String -> Instantiations +parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of [(r, "")] -> r _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) where parse = sepBy parseEntry (R.char ',') parseEntry = do n <- parseModuleName _ <- R.char '=' - m <- parseModuleId + m <- parseHoleyModule return (n, m) setUnitIdInsts :: String -> DynFlags -> DynFlags setUnitIdInsts s d = - d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) } + d { thisUnitIdInsts_ = Just (parseUnitInsts s) } setComponentId :: String -> DynFlags -> DynFlags setComponentId s d = - d { thisComponentId_ = Just (ComponentId (fsLit s) Nothing) } + d { thisComponentId_ = Just (Indefinite (UnitId (fsLit s)) Nothing) } addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } @@ -4554,13 +4555,13 @@ exposePackage, exposePackageId, hidePackage, exposePackage p = upd (exposePackage' p) exposePackageId p = upd (\s -> s{ packageFlags = - parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s }) + parsePackageFlag "-package-id" parseUnitArg p : packageFlags s }) exposePluginPackage p = upd (\s -> s{ pluginPackageFlags = parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) exposePluginPackageId p = upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s }) + parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s }) hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = @@ -4580,12 +4581,12 @@ parsePackageArg :: ReadP PackageArg parsePackageArg = fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) -parseUnitIdArg :: ReadP PackageArg -parseUnitIdArg = - fmap UnitIdArg parseUnitId +parseUnitArg :: ReadP PackageArg +parseUnitArg = + fmap UnitIdArg parseUnit setUnitId :: String -> DynFlags -> DynFlags -setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p } +setUnitId p d = d { thisUnitId = stringToUnitId p } -- | Given a 'ModuleName' of a signature in the home library, find -- out how it is instantiated. E.g., the canonical form of @@ -4598,7 +4599,7 @@ canonicalizeHomeModule dflags mod_name = canonicalizeModuleIfHome :: DynFlags -> Module -> Module canonicalizeModuleIfHome dflags mod - = if thisPackage dflags == moduleUnitId mod + = if thisPackage dflags == moduleUnit mod then canonicalizeHomeModule dflags (moduleName mod) else mod diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index 2bddbe8a54..07e7cd7001 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -872,8 +872,8 @@ type FinderCache = InstalledModuleEnv InstalledFindResult data InstalledFindResult = InstalledFound ModLocation InstalledModule - | InstalledNoPackage InstalledUnitId - | InstalledNotFound [FilePath] (Maybe InstalledUnitId) + | InstalledNoPackage UnitId + | InstalledNotFound [FilePath] (Maybe UnitId) -- | The result of searching for an imported module. -- @@ -883,29 +883,29 @@ data InstalledFindResult data FindResult = Found ModLocation Module -- ^ The module was found - | NoPackage UnitId - -- ^ The requested package was not found + | NoPackage Unit + -- ^ The requested unit was not found | FoundMultiple [(Module, ModuleOrigin)] -- ^ _Error_: both in multiple packages -- | Not found | NotFound - { fr_paths :: [FilePath] -- Places where I looked + { fr_paths :: [FilePath] -- ^ Places where I looked - , fr_pkg :: Maybe UnitId -- Just p => module is in this package's - -- manifest, but couldn't find - -- the .hi file + , fr_pkg :: Maybe Unit -- ^ Just p => module is in this unit's + -- manifest, but couldn't find the + -- .hi file - , fr_mods_hidden :: [UnitId] -- Module is in these packages, + , fr_mods_hidden :: [Unit] -- ^ Module is in these units, -- but the *module* is hidden - , fr_pkgs_hidden :: [UnitId] -- Module is in these packages, - -- but the *package* is hidden + , fr_pkgs_hidden :: [Unit] -- ^ Module is in these units, + -- but the *unit* is hidden - -- Modules are in these packages, but it is unusable - , fr_unusables :: [(UnitId, UnusablePackageReason)] + -- | Module is in these units, but it is unusable + , fr_unusables :: [(Unit, UnusablePackageReason)] - , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules + , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules } {- @@ -1134,11 +1134,11 @@ mi_semantic_module iface = case mi_sig_of iface of -- 'ModIface' depends on. mi_free_holes :: ModIface -> UniqDSet ModuleName mi_free_holes iface = - case splitModuleInsts (mi_module iface) of + case getModuleInstantiation (mi_module iface) of (_, Just indef) -- A mini-hack: we rely on the fact that 'renameFreeHoles' -- drops things that aren't holes. - -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef)) + -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef)) _ -> emptyUniqDSet where cands = map fst (dep_mods (mi_deps iface)) @@ -1517,7 +1517,7 @@ data CgGuts cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_foreign_files :: ![(ForeignSrcLang, FilePath)], - cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to + cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints @@ -1850,7 +1850,7 @@ setInteractivePackage :: HscEnv -> HscEnv -- Set the 'thisPackage' DynFlag to 'interactive' setInteractivePackage hsc_env = hsc_env { hsc_dflags = (hsc_dflags hsc_env) - { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } } + { thisUnitId = toUnitId interactiveUnitId } } setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} @@ -1944,8 +1944,8 @@ Note [Printing unit ids] In the old days, original names were tied to PackageIds, which directly corresponded to the entities that users wrote in Cabal files, and were perfectly suitable for printing when we need to disambiguate packages. However, with -UnitId, the situation can be different: if the key is instantiated with -some holes, we should try to give the user some more useful information. +instantiated units, the situation can be different: if the key is instantiated +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 @@ -2011,10 +2011,10 @@ mkPrintUnqualified dflags env = QueryQualify qual_name -- is only one exposed package which exports this module, don't qualify. mkQualModule :: DynFlags -> QueryQualifyModule mkQualModule dflags mod - | moduleUnitId mod == thisPackage dflags = False + | moduleUnit mod == thisPackage dflags = False | [(_, pkgconfig)] <- lookup, - packageConfigId pkgconfig == moduleUnitId mod + mkUnit pkgconfig == moduleUnit mod -- this says: we are given a module P:M, is there just one exposed package -- that exposes a module M, and is it package P? = False @@ -2509,7 +2509,7 @@ data Dependencies -- I.e. modules that this one imports, or that are in the -- dep_mods of those directly-imported modules - , dep_pkgs :: [(InstalledUnitId, Bool)] + , dep_pkgs :: [(UnitId, Bool)] -- ^ All packages transitively below this module -- I.e. packages to which this module's direct imports belong, -- or that are in the dep_pkgs of those modules @@ -2932,7 +2932,7 @@ data ModSummary } ms_installed_mod :: ModSummary -> InstalledModule -ms_installed_mod = fst . splitModuleInsts . ms_mod +ms_installed_mod = fst . getModuleInstantiation . ms_mod ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 7474678e3c..af204f474f 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -174,7 +174,7 @@ deSugar hsc_env ; let used_names = mkUsedNames tcg_env pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env)) - ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env)) + ; deps <- mkDependencies (thisUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tcg_env ; used_th <- readIORef tc_splice_used diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index b2f5c4d15e..a057e4bd49 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -181,8 +181,8 @@ writeMixEntries dflags mod count entries filename mod_name = moduleNameString (moduleName mod) hpc_mod_dir - | moduleUnitId mod == mainUnitId = hpc_dir - | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod) + | moduleUnit mod == mainUnitId = hpc_dir + | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod) tabStop = 8 -- <tab> counts as a normal char in GHC's -- location ranges. @@ -1336,9 +1336,9 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo) module_name = hcat (map (text.charToC) $ BS.unpack $ bytesFS (moduleNameFS (Module.moduleName this_mod))) package_name = hcat (map (text.charToC) $ BS.unpack $ - bytesFS (unitIdFS (moduleUnitId this_mod))) + bytesFS (unitFS (moduleUnit this_mod))) full_name_str - | moduleUnitId this_mod == mainUnitId + | moduleUnit this_mod == mainUnitId = module_name | otherwise = package_name <> char '/' <> module_name diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 54de211b3d..3e4de72006 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -2032,7 +2032,7 @@ globalVar name where mod = ASSERT( isExternalName name) nameModule name name_mod = moduleNameString (moduleName mod) - name_pkg = unitIdString (moduleUnitId mod) + name_pkg = unitString (moduleUnit mod) name_occ = nameOccName name mk_varg | isDataOcc name_occ = mkNameG_dName | isVarOcc name_occ = mkNameG_vName diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index c15fc022f0..e536e29b11 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -61,7 +61,7 @@ its dep_orphs. This was the cause of #14128. -- a dependencies information for the module being compiled. -- -- The first argument is additional dependencies from plugins -mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies +mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies mkDependencies iuid pluginModules (TcGblEnv{ tcg_mod = mod, tcg_imports = imports, @@ -70,7 +70,7 @@ mkDependencies iuid pluginModules = do -- Template Haskell used? let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ] - plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms) + plugin_dep_pkgs = filter (/= iuid) (map (toUnitId . moduleUnit) ms) th_used <- readIORef th_var let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports) (moduleName mod)) @@ -87,7 +87,7 @@ mkDependencies iuid pluginModules raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs - pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) raw_pkgs + pkgs | th_used = Set.insert (toUnitId thUnitId) raw_pkgs | otherwise = raw_pkgs -- Set the packages required to be Safe according to Safe Haskell. @@ -132,6 +132,8 @@ mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged -- the entire collection of Ifaces. {- Note [Plugin dependencies] + ~~~~~~~~~~~~~~~~~~~~~~~~~~ + Modules for which plugins were used in the compilation process, should be recompiled whenever one of those plugins changes. But how do we know if a plugin changed from the previous time a module was compiled? @@ -155,7 +157,7 @@ During recompilation we then compare the hashes of those files again to see if anything has changed. One issue with this approach is that object files are currently (GHC 8.6.1) -not created fully deterministicly, which could sometimes induce accidental +not created fully deterministically, which could sometimes induce accidental recompilation of a module for which plugins were used in the compile process. One way to improve this is to either: @@ -215,7 +217,7 @@ mkPluginUsage hsc_env pluginModule dflags = hsc_dflags hsc_env platform = targetPlatform dflags pNm = moduleName (mi_module pluginModule) - pPkg = moduleUnitId (mi_module pluginModule) + pPkg = moduleUnit (mi_module pluginModule) deps = map fst (dep_mods (mi_deps pluginModule)) -- Lookup object file for a plugin dependency, @@ -224,7 +226,7 @@ mkPluginUsage hsc_env pluginModule foundM <- findImportedModule hsc_env nm Nothing case foundM of Found ml m - | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml) + | moduleUnit m == pPkg -> Just <$> hashFile (ml_obj_file ml) | otherwise -> return Nothing _ -> pprPanic "mkPluginUsage: no object for dependency" (ppr pNm <+> ppr nm) @@ -294,7 +296,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names -- things in *this* module = Nothing - | moduleUnitId mod /= this_pkg + | moduleUnit mod /= this_pkg = Just UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index 3e00e8694d..e954413940 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -325,7 +325,7 @@ getSymbolTable bh ncu = do newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name) newSTArray_ = newArray_ -type OnDiskName = (UnitId, ModuleName, OccName) +type OnDiskName = (Unit, ModuleName, OccName) fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name) fromOnDiskName nc (pid, mod_name, occ) = @@ -342,7 +342,7 @@ fromOnDiskName nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let mod = ASSERT2( isExternalName name, ppr name ) nameModule name - put_ bh (moduleUnitId mod, moduleName mod, nameOccName name) + put_ bh (moduleUnit mod, moduleName mod, nameOccName name) -- Note [Symbol table representation of names] diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 0068441ee3..c35a426e07 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -619,7 +619,7 @@ is_external_sig dflags iface = -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package - moduleUnitId (mi_module iface) /= thisPackage dflags + moduleUnit (mi_module iface) /= thisPackage dflags -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only @@ -641,14 +641,14 @@ computeInterface :: computeInterface doc_str hi_boot_file mod0 = do MASSERT( not (isHoleModule mod0) ) dflags <- getDynFlags - case splitModuleInsts mod0 of - (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do + case getModuleInstantiation mod0 of + (imod, Just indef) | not (unitIsDefinite (thisPackage dflags)) -> do r <- findAndReadIface doc_str imod mod0 hi_boot_file case r of Succeeded (iface0, path) -> do hsc_env <- getTopEnv r <- liftIO $ - rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef)) + rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 case r of Right x -> return (Succeeded (x, path)) @@ -672,9 +672,9 @@ moduleFreeHolesPrecise moduleFreeHolesPrecise doc_str mod | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) | otherwise = - case splitModuleInsts mod of + case getModuleInstantiation mod of (imod, Just indef) -> do - let insts = indefUnitIdInsts (indefModuleUnitId indef) + let insts = instUnitInsts (moduleUnit indef) traceIf (text "Considering whether to load" <+> ppr mod <+> text "to compute precise free module holes") (eps, hpt) <- getEpsAndHpt @@ -726,13 +726,13 @@ wantHiBootFile dflags eps mod from -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules where - this_package = thisPackage dflags == moduleUnitId mod + this_package = thisPackage dflags == moduleUnit mod badSourceImport :: Module -> SDoc badSourceImport mod = hang (text "You cannot {-# SOURCE #-} import a module from another package") 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package") - <+> quotes (ppr (moduleUnitId mod))) + <+> quotes (ppr (moduleUnit mod))) ----------------------------------------------------- -- Loading type/class/value decls @@ -925,7 +925,7 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file (ml_hi_file loc) -- See Note [Home module load error] - if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags && + if moduleUnit mod `unitIdEq` thisPackage dflags && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do r <- read_file file_path @@ -935,7 +935,7 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file traceIf (text "...not found") dflags <- getDynFlags return (Failed (cannotFindInterface dflags - (installedModuleName mod) err)) + (moduleName mod) err)) where read_file file_path = do traceIf (text "readIFace" <+> text file_path) -- Figure out what is recorded in mi_module. If this is @@ -943,11 +943,11 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file -- if it's indefinite, the inside will be uninstantiated! dflags <- getDynFlags let wanted_mod = - case splitModuleInsts wanted_mod_with_insts of + case getModuleInstantiation wanted_mod_with_insts of (_, Nothing) -> wanted_mod_with_insts (_, Just indef_mod) -> - indefModuleToModule dflags - (generalizeIndefModule indef_mod) + instModuleToModule (pkgState dflags) + (uninstantiateInstantiatedModule indef_mod) read_result <- readIface wanted_mod file_path case read_result of Failed err -> return (Failed (badIfaceFile file_path err)) @@ -1272,7 +1272,7 @@ badIfaceFile file err hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc hiModuleNameMismatchWarn dflags requested_mod read_mod - | moduleUnitId requested_mod == moduleUnitId read_mod = + | moduleUnit requested_mod == moduleUnit read_mod = sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, text "but we were expecting module" <+> quotes (ppr requested_mod), sep [text "Probable cause: the source code which generated interface file", diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 6ffce05405..0b0c46019f 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -153,7 +153,7 @@ mkIfaceTc hsc_env safe_mode mod_details let pluginModules = map lpModule (cachedPlugins (hsc_dflags hsc_env)) deps <- mkDependencies - (thisInstalledUnitId (hsc_dflags hsc_env)) + (thisUnitId (hsc_dflags hsc_env)) (map mi_module pluginModules) tc_result let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 430f7b4207..bec782ff48 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -209,10 +209,10 @@ checkVersions hsc_env mod_summary iface = do { traceHiDiffs (text "Considering whether compilation is required for" <+> ppr (mi_module iface) <> colon) - -- readIface will have verified that the InstalledUnitId matches, + -- readIface will have verified that the UnitId matches, -- but we ALSO must make sure the instantiation matches up. See -- test case bkpcabal04! - ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env) + ; if moduleUnit (mi_module iface) /= thisPackage (hsc_dflags hsc_env) then return (RecompBecause "-this-unit-id changed", Nothing) else do { ; recomp <- checkFlagHash hsc_env iface ; if recompileRequired recomp then return (recomp, Nothing) else do { @@ -332,7 +332,7 @@ checkHsig mod_summary iface = do dflags <- getDynFlags let outer_mod = ms_mod mod_summary inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + MASSERT( moduleUnit outer_mod == thisPackage dflags ) case inner_mod == mi_semantic_module iface of True -> up_to_date (text "implementing module unchanged") False -> return (RecompBecause "implementing module changed") @@ -405,7 +405,7 @@ checkMergedSignatures mod_summary iface = do new_merged = case Map.lookup (ms_mod_name mod_summary) (requirementContext (pkgState dflags)) of Nothing -> [] - Just r -> sort $ map (indefModuleToModule dflags) r + Just r -> sort $ map (instModuleToModule (pkgState dflags)) r if old_merged == new_merged then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged) else return (RecompBecause "signatures to merge in changed") @@ -463,7 +463,7 @@ checkDependencies hsc_env summary iface else return UpToDate | otherwise - -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs) + -> if toUnitId pkg `notElem` (map fst prev_dep_pkgs) then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " is from package " <> quotes (ppr pkg) <> @@ -471,7 +471,7 @@ checkDependencies hsc_env summary iface return (RecompBecause reason) else return UpToDate - where pkg = moduleUnitId mod + where pkg = moduleUnit mod _otherwise -> return (RecompBecause reason) old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods @@ -561,7 +561,7 @@ getFromModIface doc_msg mod getter -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. -checkModUsage :: UnitId -> Usage -> IfG RecompileRequired +checkModUsage :: Unit -> Usage -> IfG RecompileRequired checkModUsage _this_pkg UsagePackageModule{ usg_mod = mod, usg_mod_hash = old_mod_hash } diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index dbe847b5f4..29c0b3e593 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -211,7 +211,7 @@ data ShIfEnv = ShIfEnv { -- The semantic module that we are renaming to sh_if_semantic_module :: Module, -- Cached hole substitution, e.g. - -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@ + -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnit . sh_if_module@ sh_if_hole_subst :: ShHoleSubst, -- An optional name substitution to be applied when renaming -- the names in the interface. If this is 'Nothing', then diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index 09125a4b53..453f859233 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -211,7 +211,7 @@ sptCreateStaticBinds hsc_env this_mod binds info <- mkConApp staticPtrInfoDataCon <$> (++[srcLoc]) <$> mapM (mkStringExprFSWith (lift . lookupIdHscEnv)) - [ unitIdFS $ moduleUnitId this_mod + [ unitFS $ moduleUnit this_mod , moduleNameFS $ moduleName this_mod ] @@ -227,7 +227,7 @@ sptCreateStaticBinds hsc_env this_mod binds mkStaticPtrFingerprint :: Int -> Fingerprint mkStaticPtrFingerprint n = fingerprintString $ intercalate ":" - [ unitIdString $ moduleUnitId this_mod + [ unitString $ moduleUnit this_mod , moduleNameString $ moduleName this_mod , show n ] diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index d895b9228e..f9edcfe196 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -515,7 +515,7 @@ tcHiBootIface hsc_src mod -- to check consistency against, rather than just when we notice -- that an hi-boot is necessary due to a circular import. { read_result <- findAndReadIface - need (fst (splitModuleInsts mod)) mod + need (fst (getModuleInstantiation mod)) mod True -- Hi-boot file ; case read_result of { diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 3a93214cb4..8b1fd41146 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -2079,7 +2079,7 @@ warnopt f options = f `EnumSet.member` pWarningFlags options -- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this. data ParserFlags = ParserFlags { pWarningFlags :: EnumSet WarningFlag - , pThisPackage :: UnitId -- ^ key of package currently being compiled + , pThisPackage :: Unit -- ^ key of package currently being compiled , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions } @@ -2174,7 +2174,7 @@ failLocMsgP loc1 loc2 str = getPState :: P PState getPState = P $ \s -> POk s s -withThisPackage :: (UnitId -> a) -> P a +withThisPackage :: (Unit -> a) -> P a withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o)) getExts :: P ExtsBitmap @@ -2492,7 +2492,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) { mkParserFlags' :: EnumSet WarningFlag -- ^ warnings flags enabled -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled - -> UnitId -- ^ key of package currently being compiled + -> Unit -- ^ key of package currently being compiled -> Bool -- ^ are safe imports on? -> Bool -- ^ keeping Haddock comment tokens -> Bool -- ^ keep regular comment tokens diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 88ad0fee94..0f17a3c6f2 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -396,21 +396,21 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) -- package, so if they get inlined across a package boundary we'll still -- know where they're from. -- -patchForeignImport :: UnitId -> ForeignImport -> ForeignImport -patchForeignImport unitId (CImport cconv safety fs spec src) - = CImport cconv safety fs (patchCImportSpec unitId spec) src +patchForeignImport :: Unit -> ForeignImport -> ForeignImport +patchForeignImport unit (CImport cconv safety fs spec src) + = CImport cconv safety fs (patchCImportSpec unit spec) src -patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec -patchCImportSpec unitId spec +patchCImportSpec :: Unit -> CImportSpec -> CImportSpec +patchCImportSpec unit spec = case spec of - CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget + CFunction callTarget -> CFunction $ patchCCallTarget unit callTarget _ -> spec -patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget -patchCCallTarget unitId callTarget = +patchCCallTarget :: Unit -> CCallTarget -> CCallTarget +patchCCallTarget unit callTarget = case callTarget of StaticTarget src label Nothing isFun - -> StaticTarget src label (Just unitId) isFun + -> StaticTarget src label (Just unit) isFun _ -> callTarget {- diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index c0832b5e35..68f08a9cfd 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -306,7 +306,7 @@ rnImportDecl this_mod -- c.f. GHC.findModule, and #9997 Nothing -> True Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" || - fsToUnitId pkg_fs == moduleUnitId this_mod)) + fsToUnit pkg_fs == moduleUnit this_mod)) (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) -- Check for a missing import list (Opt_WarnMissingImportList also @@ -440,8 +440,8 @@ calculateAvails dflags iface mod_safe' want_boot imported_by = imp_sem_mod : dep_finsts deps | otherwise = dep_finsts deps - pkg = moduleUnitId (mi_module iface) - ipkg = toInstalledUnitId pkg + pkg = moduleUnit (mi_module iface) + ipkg = toUnitId pkg -- Does this import mean we now require our own pkg -- to be trusted? See Note [Trust Own Package] diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index cf3329fb8b..802de13186 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -814,7 +814,7 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } -> -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> - if moduleUnitId modl /= thisPackage (hsc_dflags h) + if moduleUnit modl /= thisPackage (hsc_dflags h) 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/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 748020fa21..9434e2e9ec 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -139,7 +139,7 @@ isThunk _ = False constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name) constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do let occName = mkOccName OccName.dataName occ - modName = mkModule (stringToUnitId pkg) (mkModuleName mod) + modName = mkModule (stringToUnit pkg) (mkModuleName mod) Right `fmap` lookupOrigIO hsc_env modName occName constrClosToName _hsc_env clos = return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos))) diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index 574e303e64..d93c5acebc 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -141,9 +141,9 @@ emptyPLS = PersistentLinkerState -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = map toInstalledUnitId [rtsUnitId] + where init_pkgs = map toUnitId [rtsUnitId] -extendLoadedPkgs :: DynLinker -> [InstalledUnitId] -> IO () +extendLoadedPkgs :: DynLinker -> [UnitId] -> IO () extendLoadedPkgs dl pkgs = modifyPLS_ dl $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } @@ -625,7 +625,7 @@ getLinkDeps :: HscEnv -> HomePackageTable -> Maybe FilePath -- replace object suffices? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [InstalledUnitId]) -- ... then link these first + -> IO ([Linkable], [UnitId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env hpt pls replace_osuf span mods @@ -663,8 +663,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow -> UniqDSet ModuleName -- accum. module dependencies - -> UniqDSet InstalledUnitId -- accum. package dependencies - -> IO ([ModuleName], [InstalledUnitId]) -- result + -> UniqDSet UnitId -- accum. package dependencies + -> IO ([ModuleName], [UnitId]) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -678,7 +678,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods when (mi_boot iface) $ link_boot_mod_error mod let - pkg = moduleUnitId mod + pkg = moduleUnit mod deps = mi_deps iface pkg_deps = dep_pkgs deps @@ -691,7 +691,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps -- if pkg /= this_pkg - then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg)) + then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs' where @@ -1266,7 +1266,7 @@ linkPackages' hsc_env new_pks pls = do ; return (new_pkg : pkgs') } | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg))) + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) linkPackage :: HscEnv -> UnitInfo -> IO () diff --git a/compiler/GHC/Runtime/Linker/Types.hs b/compiler/GHC/Runtime/Linker/Types.hs index fce4e80e60..afbd0dae73 100644 --- a/compiler/GHC/Runtime/Linker/Types.hs +++ b/compiler/GHC/Runtime/Linker/Types.hs @@ -19,7 +19,7 @@ import GHC.Prelude ( FilePath, String, show ) import Data.Time ( UTCTime ) import Data.Maybe ( Maybe ) import Control.Concurrent.MVar ( MVar ) -import GHC.Types.Module ( InstalledUnitId, Module ) +import GHC.Types.Module ( UnitId, Module ) import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) import GHC.Utils.Outputable import GHC.Types.Var ( Id ) @@ -62,7 +62,7 @@ data PersistentLinkerState temp_sos :: ![(FilePath, String)] } -- TODO: Make this type more precise -type LinkerUnitId = InstalledUnitId +type LinkerUnitId = UnitId -- | Information we can use to dynamically link modules into the compiler data Linkable = LM { diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs index e26d971c7f..cb57d970f0 100644 --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -61,8 +61,8 @@ data Named = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, -- eg, RtsLabel, ForeignLabel, CmmLabel etc. - | FunN UnitId -- ^ A function name from this package - | LabelN BlockId -- ^ A blockid of some code or data. + | FunN Unit -- ^ A function name from this package + | LabelN BlockId -- ^ A blockid of some code or data. -- | An environment of named things. type Env = UniqFM Named @@ -165,7 +165,7 @@ newLabel name = do -- | Add add a local function to the environment. newFunctionName :: FastString -- ^ name of the function - -> UnitId -- ^ package of the current module + -> Unit -- ^ package of the current module -> ExtCode newFunctionName name pkg = addDecl name (FunN pkg) diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 5516c2e7bc..894b8a0fd2 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -474,7 +474,7 @@ instance HasDynFlags FCode where getPlatform :: FCode Platform getPlatform = targetPlatform <$> getDynFlags -getThisPackage :: FCode UnitId +getThisPackage :: FCode Unit getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index d60de74267..6bb1022819 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -181,10 +181,10 @@ tagToClosure platform tycon tag -- ------------------------------------------------------------------------- -emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCall :: Unit -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe -emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString +emitRtsCallWithResult :: LocalReg -> ForeignHint -> Unit -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs index 0ec9912c8d..604cd60fd1 100644 --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -228,7 +228,7 @@ copyWithHeader dflags purpose maybe_header from to = do ************************************************************************ -} -linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () +linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO () linkDynLib dflags0 o_files dep_packages = do let -- This is a rather ugly hack to fix dynamically linked @@ -277,7 +277,7 @@ linkDynLib dflags0 o_files dep_packages OSMinGW32 -> pkgs _ -> - filter ((/= rtsUnitId) . packageConfigId) pkgs + filter ((/= rtsUnitId) . mkUnit) pkgs let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts in package_hs_libs ++ extra_libs ++ other_flags @@ -422,7 +422,7 @@ libmLinkOpts = [] #endif -getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String] +getPkgFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String] getPkgFrameworkOpts dflags platform dep_packages | platformUsesFrameworks platform = do pkg_framework_path_opts <- do diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs index 652d8cd897..e8715d4048 100644 --- a/compiler/GHC/SysTools/ExtraObj.hs +++ b/compiler/GHC/SysTools/ExtraObj.hs @@ -55,7 +55,7 @@ mkExtraObj dflags extn xs -- set of include directories and PIC flags. cOpts = map Option (picCCOpts dflags) ++ map (FileOption "-I") - (unitIncludeDirs $ getPackageDetails dflags rtsUnitId) + (unitIncludeDirs $ unsafeGetUnitInfo dflags rtsUnitId) -- When compiling assembler code, we drop the usual C options, and if the -- compiler is Clang, we add an extra argument to tell Clang to ignore @@ -139,7 +139,7 @@ mkExtraObjToLinkIntoBinary dflags = do -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath] mkNoteObjsToLinkIntoBinary dflags dep_packages = do link_info <- getLinkInfo dflags dep_packages @@ -166,7 +166,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do -- | Return the "link info" string -- -- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String +getLinkInfo :: DynFlags -> [UnitId] -> IO String getLinkInfo dflags dep_packages = do package_link_opts <- getPackageLinkOpts dflags dep_packages pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) @@ -200,7 +200,7 @@ ghcLinkInfoNoteName = "GHC link info" -- Returns 'False' if it was, and we can avoid linking, because the -- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool +checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool checkLinkInfo dflags pkg_deps exe_file | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) -- ToDo: Windows and OS X do not use the ELF binary format, so diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index 31dc85d7e9..9205856996 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -31,7 +31,7 @@ import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) import GHC.Tc.Instance.Family import GHC.Types.Module ( moduleName, moduleNameFS - , moduleUnitId, unitIdFS, getModule ) + , moduleUnit, unitFS, getModule ) import GHC.Iface.Env ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader @@ -615,7 +615,7 @@ tc_mkRepTy gk_ tycon k = dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user mdName = mkStrLitTy . moduleNameFS . moduleName . nameModule . tyConName $ tycon - pkgName = mkStrLitTy . unitIdFS . moduleUnitId + pkgName = mkStrLitTy . unitFS . moduleUnit . nameModule . tyConName $ tycon isNT = mkTyConTy $ if isNewTyCon tycon then promotedTrueDataCon diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index e4746032d3..b90eae080b 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -2149,7 +2149,7 @@ sameOccExtra ty1 ty2 , let n1 = tyConName tc1 n2 = tyConName tc2 same_occ = nameOccName n1 == nameOccName n2 - same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2) + same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) , n1 /= n2 -- Different Names , same_occ -- but same OccName = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) @@ -2166,7 +2166,7 @@ sameOccExtra ty1 ty2 , ppUnless (same_pkg || pkg == mainUnitId) $ nest 4 $ text "in package" <+> quotes (ppr pkg) ]) where - pkg = moduleUnitId mod + pkg = moduleUnit mod mod = nameModule nm loc = nameSrcSpan nm diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 67ef5a3e6c..2b308bf753 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1087,7 +1087,7 @@ instance TH.Quasi TcM where RealSrcSpan s _ -> return s ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitIdString (moduleUnitId m) + , TH.loc_package = unitString (moduleUnit m) , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } @@ -2216,7 +2216,7 @@ reifyName thing where name = getName thing mod = ASSERT( isExternalName name ) nameModule name - pkg_str = unitIdString (moduleUnitId mod) + pkg_str = unitString (moduleUnit mod) mod_str = moduleNameString (moduleName mod) occ_str = occNameString occ occ = nameOccName name @@ -2234,7 +2234,7 @@ reifyFieldLabel fl where name = flSelector fl mod = ASSERT( isExternalName name ) nameModule name - pkg_str = unitIdString (moduleUnitId mod) + pkg_str = unitString (moduleUnit mod) mod_str = moduleNameString (moduleName mod) occ_str = unpackFS (flLabel fl) @@ -2296,7 +2296,7 @@ lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) = return $ ModuleTarget $ - mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn) + mkModule (stringToUnit $ TH.pkgString pn) (mkModuleName $ TH.modString mn) reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] reifyAnnotations th_name @@ -2310,13 +2310,13 @@ reifyAnnotations th_name ------------------------------ modToTHMod :: Module -> TH.Module -modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m) +modToTHMod m = TH.Module (TH.PkgName $ unitString $ moduleUnit m) (TH.ModName $ moduleNameString $ moduleName m) reifyModule :: TH.Module -> TcM TH.ModuleInfo reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do this_mod <- getModule - let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString) + let reifMod = mkModule (stringToUnit pkgString) (mkModuleName mString) if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod where reifyThisModule = do @@ -2326,10 +2326,10 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do reifyFromIface reifMod = do iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod let usages = [modToTHMod m | usage <- mi_usages iface, - Just m <- [usageToModule (moduleUnitId reifMod) usage] ] + Just m <- [usageToModule (moduleUnit reifMod) usage] ] return $ TH.ModuleInfo usages - usageToModule :: UnitId -> Usage -> Maybe Module + usageToModule :: Unit -> Usage -> Maybe Module usageToModule _ (UsageFile {}) = Nothing usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 6f1ac07f74..507da20c92 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -632,7 +632,7 @@ loadDependentFamInstModules fam_insts want_module mod -- See Note [Home package family instances] | mod == this_mod = False - | home_fams_only = moduleUnitId mod == moduleUnitId this_mod + | home_fams_only = moduleUnit mod == moduleUnit this_mod | otherwise = True home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index 2c7656a20c..2de4e057b0 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -205,7 +205,7 @@ mkModIdRHS mod = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName ; trNameLit <- mkTrNameLit ; return $ nlHsDataCon trModuleDataCon - `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod)) + `nlHsApp` trNameLit (unitFS (moduleUnit mod)) `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) } @@ -265,7 +265,7 @@ todoForTyCons mod mod_id tycons = do } where mod_fpr = fingerprintString $ moduleNameString $ moduleName mod - pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod + pkg_fpr = fingerprintString $ unitString $ moduleUnit mod todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo todoForExportedKindReps kinds = do diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index e202fdcec7..516aea677e 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -35,7 +35,7 @@ module GHC.Tc.Module ( checkBootDecl, checkHiBootIface', findExtraSigImports, implicitRequirements, - checkUnitId, + checkUnit, mergeSignatures, tcRnMergeSignatures, instantiateSignature, diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 1f44338a4c..93637329ad 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -4037,7 +4037,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!) - , unitIdIsDefinite (thisPackage dflags) + , unitIsDefinite (thisPackage dflags) = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) where is_strict = case strict_mark of diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 890222b8aa..ad0aec3ac1 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -181,11 +181,11 @@ checkNameIsAcyclic n m = SynCycleM $ \s -> Left err -> Left err -- | Checks if any of the passed in 'TyCon's have cycles. --- Takes the 'UnitId' of the home package (as we can avoid +-- Takes the 'Unit' of the home package (as we can avoid -- checking those TyCons: cycles never go through foreign packages) and -- the corresponding @LTyClDecl Name@ for each 'TyCon', so we -- can give better error messages. -checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () +checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () checkSynCycles this_uid tcs tyclds = do case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of Left (loc, err) -> setSrcSpan loc $ failWithTc err @@ -215,7 +215,7 @@ checkSynCycles this_uid tcs tyclds = do -- This won't hold once we get recursive packages with Backpack, -- but for now it's fine. | not (isHoleModule mod || - moduleUnitId mod == this_uid || + moduleUnit mod == this_uid || isInteractiveModule mod) = return () | Just ty <- synTyConRhs_maybe tc = diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index be345c4f30..2dab080afb 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -381,7 +381,7 @@ data FrontendResult -- -- if I have a Module, this_mod, in hand representing the module -- currently being compiled, --- then moduleUnitId this_mod == thisPackage dflags +-- then moduleUnit this_mod == thisPackage dflags -- -- - For any code involving Names, we want semantic modules. -- See lookupIfaceTop in GHC.Iface.Env, mkIface and addFingerprints @@ -1350,12 +1350,12 @@ data ImportAvails -- compiling M might not need to consult X.hi, but X -- is still listed in M's dependencies. - imp_dep_pkgs :: Set InstalledUnitId, + imp_dep_pkgs :: Set UnitId, -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. - imp_trust_pkgs :: Set InstalledUnitId, + imp_trust_pkgs :: Set UnitId, -- ^ This is strictly a subset of imp_dep_pkgs and records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs index 1352ceca90..063b5652cc 100644 --- a/compiler/GHC/Tc/Types/EvTerm.hs +++ b/compiler/GHC/Tc/Types/EvTerm.hs @@ -41,7 +41,7 @@ evCallStack cs = do m <- getModule srcLocDataCon <- lookupDataCon srcLocDataConName let mkSrcLoc l = mkCoreConApps srcLocDataCon <$> - sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) + sequence [ mkStringExprFS (unitFS $ moduleUnit m) , mkStringExprFS (moduleNameFS $ moduleName m) , mkStringExprFS (srcSpanFile l) , return $ mkIntExprInt platform (srcSpanStartLine l) diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 53d76f7b2a..70e163c0c6 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -10,8 +10,8 @@ module GHC.Tc.Utils.Backpack ( findExtraSigImports, implicitRequirements', implicitRequirements, - checkUnitId, - tcRnCheckUnitId, + checkUnit, + tcRnCheckUnit, tcRnMergeSignatures, mergeSignatures, tcRnInstantiateSignature, @@ -231,17 +231,17 @@ check_inst sig_inst = do -- | Return this list of requirement interfaces that need to be merged -- to form @mod_name@, or @[]@ if this is not a requirement. -requirementMerges :: PackageState -> ModuleName -> [IndefModule] +requirementMerges :: PackageState -> ModuleName -> [InstantiatedModule] requirementMerges pkgstate mod_name = fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate)) where - -- update ComponentId cached details as they may have changed since the - -- time the ComponentId was created - fixupModule (IndefModule iud name) = IndefModule iud' name + -- update IndefUnitId ppr info as they may have changed since the + -- time the IndefUnitId was created + fixupModule (Module iud name) = Module iud' name where - iud' = iud { indefUnitIdComponentId = cid' } - cid = indefUnitIdComponentId iud - cid' = updateComponentId pkgstate cid + iud' = iud { instUnitInstanceOf = cid' } + cid = instUnitInstanceOf iud + cid' = updateIndefUnitId pkgstate cid -- | For a module @modname@ of type 'HscSource', determine the list -- of extra "imports" of other requirements which should be considered part of @@ -268,11 +268,11 @@ findExtraSigImports' :: HscEnv -> ModuleName -> IO (UniqDSet ModuleName) findExtraSigImports' hsc_env HsigFile modname = - fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) -> + fmap unionManyUniqDSets (forM reqs $ \(Module iuid mod_name) -> (initIfaceLoad hsc_env . withException $ moduleFreeHolesPrecise (text "findExtraSigImports") - (mkModule (IndefiniteUnitId iuid) mod_name))) + (mkModule (VirtUnit iuid) mod_name))) where pkgstate = pkgState (hsc_dflags hsc_env) reqs = requirementMerges pkgstate modname @@ -309,37 +309,34 @@ 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 | thisPackage dflags /= moduleUnitId mod -> + Found _ mod | thisPackage dflags /= moduleUnit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where dflags = hsc_dflags hsc_env --- | Given a 'UnitId', make sure it is well typed. This is because +-- | 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 -- not; a component may have been filled with implementations for the holes -- that don't actually fulfill the requirements. --- --- INVARIANT: the UnitId is NOT a InstalledUnitId -checkUnitId :: UnitId -> TcM () -checkUnitId uid = do - case splitUnitIdInsts uid of - (_, Just indef) -> - let insts = indefUnitIdInsts indef in - forM_ insts $ \(mod_name, mod) -> - -- NB: direct hole instantiations are well-typed by construction - -- (because we FORCE things to be merged in), so don't check them - when (not (isHoleModule mod)) $ do - checkUnitId (moduleUnitId mod) - _ <- mod `checkImplements` IndefModule indef mod_name - return () - _ -> return () -- if it's hashed, must be well-typed +checkUnit :: Unit -> TcM () +checkUnit HoleUnit = return () +checkUnit (RealUnit _) = return () -- if it's already compiled, must be well-typed +checkUnit (VirtUnit indef) = do + let insts = instUnitInsts indef + forM_ insts $ \(mod_name, mod) -> + -- NB: direct hole instantiations are well-typed by construction + -- (because we FORCE things to be merged in), so don't check them + when (not (isHoleModule mod)) $ do + checkUnit (moduleUnit mod) + _ <- mod `checkImplements` Module indef mod_name + return () -- | Top-level driver for signature instantiation (run when compiling -- an @hsig@ file.) -tcRnCheckUnitId :: - HscEnv -> UnitId -> +tcRnCheckUnit :: + HscEnv -> Unit -> IO (Messages, Maybe ()) -tcRnCheckUnitId hsc_env uid = +tcRnCheckUnit hsc_env uid = withTiming dflags (text "Check unit id" <+> ppr uid) (const ()) $ @@ -348,7 +345,7 @@ tcRnCheckUnitId hsc_env uid = False mAIN -- bogus (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus - $ checkUnitId uid + $ checkUnit uid where dflags = hsc_dflags hsc_env loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) @@ -486,7 +483,7 @@ inheritedSigPvpWarning = -- logically "implicit" entities are defined indirectly in an interface -- file. #13151 gives a proposal to make these *truly* implicit. -merge_msg :: ModuleName -> [IndefModule] -> SDoc +merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc merge_msg mod_name [] = text "while checking the local signature" <+> ppr mod_name <+> text "for consistency" @@ -547,9 +544,9 @@ mergeSignatures addErrCtxt (merge_msg mod_name reqs) $ do -- STEP 2: Read in the RAW forms of all of these interfaces - ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) -> - let m = mkModule (IndefiniteUnitId iuid) mod_name - im = fst (splitModuleInsts m) + ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) -> + let m = mkModule (VirtUnit iuid) mod_name + im = fst (getModuleInstantiation m) in fmap fst . withException $ findAndReadIface (text "mergeSignatures") im m False @@ -567,11 +564,11 @@ mergeSignatures -- 3. Thinning the interface according to an explicit export -- list. -- - gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do - let insts = indefUnitIdInsts iuid + gen_subst (nsubst,oks,ifaces) (imod@(Module iuid _), ireq_iface) = do + let insts = instUnitInsts iuid isFromSignaturePackage = - let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid)) - pkg = getInstalledPackageDetails pkgstate inst_uid + let inst_uid = instUnitInstanceOf iuid + pkg = getInstalledPackageDetails pkgstate (indefUnit inst_uid) in null (unitExposedModules pkg) -- 3(a). Rename the exports according to how the dependency -- was instantiated. The resulting export list will be accurate @@ -732,8 +729,8 @@ mergeSignatures tcg_env <- getGblEnv -- STEP 4: Rename the interfaces - ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) -> - tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface + ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) -> + tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0 let ifaces = lcl_iface : ext_ifaces @@ -899,8 +896,8 @@ tcRnInstantiateSignature hsc_env this_mod real_loc = exportOccs :: [AvailInfo] -> [OccName] exportOccs = concatMap (map occName . availNames) -impl_msg :: Module -> IndefModule -> SDoc -impl_msg impl_mod (IndefModule req_uid req_mod_name) = +impl_msg :: Module -> InstantiatedModule -> SDoc +impl_msg impl_mod (Module req_uid req_mod_name) = text "while checking that" <+> ppr impl_mod <+> text "implements signature" <+> ppr req_mod_name <+> text "in" <+> ppr req_uid @@ -908,10 +905,10 @@ impl_msg impl_mod (IndefModule req_uid req_mod_name) = -- | Check if module implements a signature. (The signature is -- always un-hashed, which is why its components are specified -- explicitly.) -checkImplements :: Module -> IndefModule -> TcRn TcGblEnv -checkImplements impl_mod req_mod@(IndefModule uid mod_name) = +checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv +checkImplements impl_mod req_mod@(Module uid mod_name) = addErrCtxt (impl_msg impl_mod req_mod) $ do - let insts = indefUnitIdInsts uid + let insts = instUnitInsts uid -- STEP 1: Load the implementing interface, and make a RdrEnv -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports', @@ -954,8 +951,8 @@ checkImplements impl_mod req_mod@(IndefModule uid mod_name) = -- the ORIGINAL signature. We are going to eventually rename it, -- but we must proceed slowly, because it is NOT known if the -- instantiation is correct. - let sig_mod = mkModule (IndefiniteUnitId uid) mod_name - isig_mod = fst (splitModuleInsts sig_mod) + let sig_mod = mkModule (VirtUnit uid) mod_name + isig_mod = fst (getModuleInstantiation sig_mod) mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface @@ -1003,9 +1000,9 @@ instantiateSignature = do -- 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( moduleUnitId outer_mod == thisPackage dflags ) + MASSERT( moduleUnit outer_mod == thisPackage dflags ) inner_mod `checkImplements` - IndefModule - (newIndefUnitId (thisComponentId dflags) - (thisUnitIdInsts dflags)) + Module + (mkInstantiatedUnit (thisComponentId dflags) + (thisUnitIdInsts dflags)) (moduleName outer_mod) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index d1a92298db..4658b63f00 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -1022,7 +1022,7 @@ mkWrapperName what nameBase thisMod <- getModule let -- Note [Generating fresh names for ccall wrapper] wrapperRef = nextWrapperNum dflags - pkg = unitIdString (moduleUnitId thisMod) + pkg = unitString (moduleUnit thisMod) mod = moduleNameString (moduleName thisMod) wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> let num = lookupWithDefaultModuleEnv mod_env 0 thisMod diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 60714e4cc1..5d753e7b23 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -264,7 +264,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, tcg_field_env = emptyNameEnv, - tcg_default = if moduleUnitId mod == primUnitId + tcg_default = if moduleUnit mod == primUnitId then Just [] -- See Note [Default types] else Nothing, tcg_type_env = emptyNameEnv, @@ -1841,7 +1841,7 @@ initIfaceTcRn thing_inside ; let !mod = tcg_semantic_mod tcg_env -- When we are instantiating a signature, we DEFINITELY -- do not want to knot tie. - is_instantiate = unitIdIsDefinite (thisPackage dflags) && + is_instantiate = unitIsDefinite (thisPackage dflags) && not (null (thisUnitIdInsts dflags)) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index aad08d862e..1c44d0f6c0 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1929,8 +1929,8 @@ mk_ghc_ns TH.VarName = OccName.varName mk_mod :: TH.ModName -> ModuleName mk_mod mod = mkModuleName (TH.modString mod) -mk_pkg :: TH.PkgName -> UnitId -mk_pkg pkg = stringToUnitId (TH.pkgString pkg) +mk_pkg :: TH.PkgName -> Unit +mk_pkg pkg = stringToUnit (TH.pkgString pkg) mk_uniq :: Int -> Unique mk_uniq u = mkUniqueGrimily u diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs index 0ab67c7b35..6c0fc2a4a8 100644 --- a/compiler/GHC/Types/ForeignCall.hs +++ b/compiler/GHC/Types/ForeignCall.hs @@ -112,7 +112,7 @@ data CCallTarget -- See note [Pragma source text] in GHC.Types.Basic CLabelString -- C-land name of label. - (Maybe UnitId) -- What package the function is in. + (Maybe Unit) -- What package the function is in. -- If Nothing, then it's taken to be in the current package. -- Note: This information is only used for PrimCalls on Windows. -- See CLabel.labelDynamic and CoreToStg.coreToStgApp diff --git a/compiler/GHC/Types/Module.hs b/compiler/GHC/Types/Module.hs index eb27d6a153..aa1baad89f 100644 --- a/compiler/GHC/Types/Module.hs +++ b/compiler/GHC/Types/Module.hs @@ -11,6 +11,11 @@ the keys. {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} module GHC.Types.Module ( @@ -27,53 +32,59 @@ module GHC.Types.Module mkModuleNameFS, stableModuleNameCmp, - -- * The UnitId type - ComponentId(..), - ComponentDetails(..), + -- * The Unit type + Indefinite(..), + IndefUnitId, + UnitPprInfo(..), + GenUnit(..), + mapGenUnit, + Unit, + unitFS, + unitKey, + GenInstantiatedUnit(..), + InstantiatedUnit, + instUnitToUnit, + instModuleToModule, UnitId(..), - unitIdFS, - unitIdKey, - IndefUnitId(..), - IndefModule(..), - indefUnitIdToUnitId, - indefModuleToModule, - InstalledUnitId(..), - toInstalledUnitId, + toUnitId, ShHoleSubst, - - unitIdIsDefinite, - unitIdString, - unitIdFreeHoles, - - newUnitId, - newIndefUnitId, - newSimpleUnitId, - hashUnitId, - fsToUnitId, - stringToUnitId, - stableUnitIdCmp, + Instantiations, + GenInstantiations, + + unitIsDefinite, + unitString, + unitFreeModuleHoles, + + mkGenVirtUnit, + mkVirtUnit, + mkGenInstantiatedUnit, + mkInstantiatedUnit, + mkGenInstantiatedUnitHash, + mkInstantiatedUnitHash, + fsToUnit, + stringToUnit, + stableUnitCmp, -- * HOLE renaming - renameHoleUnitId, + renameHoleUnit, renameHoleModule, - renameHoleUnitId', + renameHoleUnit', renameHoleModule', -- * Generalization - splitModuleInsts, - splitUnitIdInsts, - generalizeIndefUnitId, - generalizeIndefModule, + getModuleInstantiation, + getUnitInstantiations, + uninstantiateInstantiatedUnit, + uninstantiateInstantiatedModule, -- * Parsers parseModuleName, - parseUnitId, - parseComponentId, - parseModuleId, + parseUnit, + parseIndefUnitId, + parseHoleyModule, parseModSubst, -- * Wired-in UnitIds - -- $wired_in_packages primUnitId, integerUnitId, baseUnitId, @@ -86,8 +97,10 @@ module GHC.Types.Module wiredInUnitIds, -- * The Module type - Module(Module), - moduleUnitId, moduleName, + GenModule(..), + type Module, + type InstalledModule, + type InstantiatedModule, pprModule, mkModule, mkHoleModule, @@ -96,20 +109,19 @@ module GHC.Types.Module ContainsModule(..), -- * Installed unit ids and modules - InstalledModule(..), InstalledModuleEnv, installedModuleEq, - installedUnitIdEq, - installedUnitIdString, - fsToInstalledUnitId, - componentIdToInstalledUnitId, - stringToInstalledUnitId, + unitIdEq, + unitIdString, + fsToUnitId, + stringToUnitId, emptyInstalledModuleEnv, lookupInstalledModuleEnv, extendInstalledModuleEnv, filterInstalledModuleEnv, delInstalledModuleEnv, - DefUnitId(..), + DefUnitId, + Definite(..), -- * The ModuleLocation type ModLocation(..), @@ -163,6 +175,7 @@ import Control.DeepSeq import Data.Coerce import Data.Data import Data.Function +import Data.Bifunctor import Data.Map (Map) import Data.Set (Set) import qualified Data.Map as Map @@ -171,80 +184,198 @@ import qualified GHC.Data.FiniteMap as Map import System.FilePath import {-# SOURCE #-} GHC.Driver.Session (DynFlags) -import {-# SOURCE #-} GHC.Driver.Packages (improveUnitId, componentIdString, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId, getPackageState) +import {-# SOURCE #-} GHC.Driver.Packages (improveUnit, UnitInfoMap, getUnitInfoMap, displayUnitId, getPackageState, PackageState, unitInfoMap) -- Note [The identifier lexicon] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Unit IDs, installed package IDs, ABI hashes, package names, --- versions, there are a *lot* of different identifiers for closely --- related things. What do they all mean? Here's what. (See also --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts ) --- --- THE IMPORTANT ONES --- --- ComponentId: An opaque identifier provided by Cabal, which should --- uniquely identify such things as the package name, the package --- version, the name of the component, the hash of the source code --- tarball, the selected Cabal flags, GHC flags, direct dependencies of --- the component. These are very similar to InstalledPackageId, but --- an 'InstalledPackageId' implies that it identifies a package, while --- a package may install multiple components with different --- 'ComponentId's. --- - Same as Distribution.Package.ComponentId --- --- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names --- (ModuleName) to Modules. This is how the compiler identifies instantiated --- components, and also is the main identifier by which GHC identifies things. --- - When Backpack is not being used, UnitId = ComponentId. --- this means a useful fiction for end-users is that there are --- only ever ComponentIds, and some ComponentIds happen to have --- more information (UnitIds). --- - Same as Language.Haskell.TH.Syntax:PkgName, see --- https://gitlab.haskell.org/ghc/ghc/issues/10279 --- - The same as PackageKey in GHC 7.10 (we renamed it because --- they don't necessarily identify packages anymore.) --- - Same as -this-package-key/-package-name flags --- - An InstalledUnitId corresponds to an actual package which --- we have installed on disk. It could be definite or indefinite, --- but if it's indefinite, it has nothing instantiated (we --- never install partially instantiated units.) --- --- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how --- the compiler identifies modules (e.g. a Name is a Module + OccName) --- - Same as Language.Haskell.TH.Syntax:Module --- --- THE LESS IMPORTANT ONES --- --- PackageName: The "name" field in a Cabal file, something like "lens". --- - Same as Distribution.Package.PackageName --- - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see --- https://gitlab.haskell.org/ghc/ghc/issues/10279 --- - DIFFERENT FROM -package-name flag --- - DIFFERENT FROM the 'name' field in an installed package --- information. This field could more accurately be described --- as a munged package name: when it's for the main library --- it is the same as the package name, but if it's an internal --- library it's a munged combination of the package name and --- the component name. --- --- LEGACY ONES --- --- InstalledPackageId: This is what we used to call ComponentId. --- It's a still pretty useful concept for packages that have only --- one library; in that case the logical InstalledPackageId = --- ComponentId. Also, the Cabal nix-local-build continues to --- compute an InstalledPackageId which is then forcibly used --- for all components in a package. This means that if a dependency --- from one component in a package changes, the InstalledPackageId --- changes: you don't get as fine-grained dependency tracking, --- but it means your builds are hermetic. Eventually, Cabal will --- deal completely in components and we can get rid of this. --- --- PackageKey: This is what we used to call UnitId. We ditched --- "Package" from the name when we realized that you might want to --- assign different "PackageKeys" to components from the same package. --- (For a brief, non-released period of time, we also called these --- UnitKeys). +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Haskell users are used to manipulate Cabal packages. These packages are +-- identified by: +-- - a package name :: String +-- - a package version :: Version +-- - (a revision number, when they are registered on Hackage) +-- +-- Cabal packages may contain several components (libraries, programs, +-- testsuites). In GHC we are mostly interested in libraries because those are +-- the components that can be depended upon by other components. Components in a +-- package are identified by their component name. Historically only one library +-- component was allowed per package, hence it didn't need a name. For this +-- reason, component name may be empty for one library component in each +-- package: +-- - a component name :: Maybe String +-- +-- UnitId +-- ------ +-- +-- Cabal libraries can be compiled in various ways (different compiler options +-- or Cabal flags, different dependencies, etc.), hence using package name, +-- package version and component name isn't enough to identify a built library. +-- We use another identifier called UnitId: +-- +-- package name \ +-- package version | ________ +-- component name | hash of all this ==> | UnitId | +-- Cabal flags | -------- +-- compiler options | +-- dependencies' UnitId / +-- +-- Fortunately GHC doesn't have to generate these UnitId: they are provided by +-- external build tools (e.g. Cabal) with `-this-unit-id` command-line flag. +-- +-- UnitIds are important because they are used to generate internal names +-- (symbols, etc.). +-- +-- Wired-in units +-- -------------- +-- +-- Certain libraries are known to the compiler, in that we know about certain +-- entities that reside in these libraries. The compiler needs to declare static +-- Modules and Names that refer to units built from these libraries. +-- +-- Hence UnitIds of wired-in libraries are fixed. Instead of letting Cabal chose +-- the UnitId for these libraries, their .cabal file use the following stanza to +-- force it to a specific value: +-- +-- ghc-options: -this-unit-id ghc-prim -- taken from ghc-prim.cabal +-- +-- The RTS also uses entities of wired-in units by directly referring to symbols +-- such as "base_GHCziIOziException_heapOverflow_closure" where the prefix is +-- the UnitId of "base" unit. +-- +-- Unit databases +-- -------------- +-- +-- Units are stored in databases in order to be reused by other codes: +-- +-- UnitKey ---> UnitInfo { exposed modules, package name, package version +-- component name, various file paths, +-- dependencies :: [UnitKey], etc. } +-- +-- Because of the wired-in units described above, we can't exactly use UnitIds +-- as UnitKeys in the database: if we did this, we could only have a single unit +-- (compiled library) in the database for each wired-in library. As we want to +-- support databases containing several different units for the same wired-in +-- library, we do this: +-- +-- * for non wired-in units: +-- * UnitId = UnitKey = Identifier (hash) computed by Cabal +-- +-- * for wired-in units: +-- * UnitKey = Identifier computed by Cabal (just like for non wired-in units) +-- * UnitId = unit-id specified with -this-unit-id command-line flag +-- +-- We can expose several units to GHC via the `package-id <UnitKey>` +-- command-line parameter. We must use the UnitKeys of the units so that GHC can +-- find them in the database. +-- +-- GHC then replaces the UnitKeys with UnitIds by taking into account wired-in +-- units: these units are detected thanks to their UnitInfo (especially their +-- package name). +-- +-- For example, knowing that "base", "ghc-prim" and "rts" are wired-in packages, +-- the following dependency graph expressed with UnitKeys (as found in the +-- database) will be transformed into a similar graph expressed with UnitIds +-- (that are what matters for compilation): +-- +-- UnitKeys +-- ~~~~~~~~ ---> rts-1.0-hashABC <-- +-- | | +-- | | +-- foo-2.0-hash123 --> base-4.1-hashXYZ ---> ghc-prim-0.5.3-hashABC +-- +-- UnitIds +-- ~~~~~~~ ---> rts <-- +-- | | +-- | | +-- foo-2.0-hash123 --> base ---------------> ghc-prim +-- +-- +-- Module signatures / indefinite units / instantiated units +-- --------------------------------------------------------- +-- +-- GHC distinguishes two kinds of units: +-- +-- * definite: units for which every module has an associated code object +-- (i.e. real compiled code in a .o/.a/.so/.dll/...) +-- +-- * indefinite: units for which some modules are replaced by module +-- signatures. +-- +-- Module signatures are a kind of interface (similar to .hs-boot files). They +-- are used in place of some real code. GHC allows real modules from other +-- units to be used to fill these module holes. The process is called +-- "unit/module instantiation". +-- +-- You can think of this as polymorphism at the module level: module signatures +-- give constraints on the "type" of module that can be used to fill the hole +-- (where "type" means types of the exported module entitites, etc.). +-- +-- Module signatures contain enough information (datatypes, abstract types, type +-- synonyms, classes, etc.) to typecheck modules depending on them but not +-- enough to compile them. As such, indefinite units found in databases only +-- provide module interfaces (the .hi ones this time), not object code. +-- +-- To distinguish between indefinite and finite unit ids at the type level, we +-- respectively use 'IndefUnitId' and 'DefUnitId' datatypes that are basically +-- wrappers over 'UnitId'. +-- +-- Unit instantiation +-- ------------------ +-- +-- Indefinite units can be instantiated with modules from other units. The +-- instantiating units can also be instantiated themselves (if there are +-- indefinite) and so on. The 'Unit' datatype represents a unit which may have +-- been instantiated: +-- +-- data Unit = RealUnit DefUnitId +-- | VirtUnit InstantiatedUnit +-- +-- 'InstantiatedUnit' has two interesting fields: +-- +-- * instUnitInstanceOf :: IndefUnitId +-- -- ^ the indefinite unit that is instantiated +-- +-- * instUnitInsts :: [(ModuleName,(Unit,ModuleName)] +-- -- ^ a list of instantiations, where an instantiation is: +-- (module hole name, (instantiating unit, instantiating module name)) +-- +-- A 'Unit' may be indefinite or definite, it depends on whether some holes +-- remain in the instantiated unit OR in the instantiating units (recursively). +-- +-- Pretty-printing UnitId +-- ---------------------- +-- +-- GHC mostly deals with UnitIds which are some opaque strings. We could display +-- them when we pretty-print a module origin, a name, etc. But it wouldn't be +-- very friendly to the user because of the hash they usually contain. E.g. +-- +-- foo-4.18.1:thelib-XYZsomeUglyHashABC +-- +-- Instead when we want to pretty-print a 'UnitId' we query the database to +-- get the 'UnitInfo' and print something nicer to the user: +-- +-- foo-4.18.1:thelib +-- +-- We do the same for wired-in units. +-- +-- Currently (2020-04-06), we don't thread the database into every function that +-- pretty-prints a Name/Module/Unit. Instead querying the database is delayed +-- until the `SDoc` is transformed into a `Doc` using the database that is +-- active at this point in time. This is an issue because we want to be able to +-- unload units from the database and we also want to support several +-- independent databases loaded at the same time (see #14335). The alternatives +-- we have are: +-- +-- * threading the database into every function that pretty-prints a UnitId +-- for the user (directly or indirectly). +-- +-- * storing enough info to correctly display a UnitId into the UnitId +-- datatype itself. This is done in the IndefUnitId wrapper (see +-- 'UnitPprInfo' datatype) but not for every 'UnitId'. Statically defined +-- 'UnitId' for wired-in units would have empty UnitPprInfo so we need to +-- find some places to update them if we want to display wired-in UnitId +-- correctly. This leads to a solution similar to the first one above. +-- {- ************************************************************************ @@ -374,7 +505,7 @@ moduleNameString (ModuleName mod) = unpackFS mod -- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" moduleStableString :: Module -> String moduleStableString Module{..} = - "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName + "$" ++ unitString moduleUnit ++ "$" ++ moduleNameString moduleName mkModuleName :: String -> ModuleName mkModuleName s = ModuleName (mkFastString s) @@ -402,18 +533,25 @@ moduleNameColons = dots_to_colons . moduleNameString ************************************************************************ -} --- | A Module is a pair of a 'UnitId' and a 'ModuleName'. --- --- Module variables (i.e. @<H>@) which can be instantiated to a --- specific module at some later point in time are represented --- with 'moduleUnitId' set to 'holeUnitId' (this allows us to --- avoid having to make 'moduleUnitId' a partial operation.) --- -data Module = Module { - moduleUnitId :: !UnitId, -- pkg-1.0 - moduleName :: !ModuleName -- A.B.C - } - deriving (Eq, Ord) +-- | A generic module is a pair of a unit identifier and a 'ModuleName'. +data GenModule unit = Module + { moduleUnit :: !unit -- ^ Unit the module belongs to + , moduleName :: !ModuleName -- ^ Module name (e.g. A.B.C) + } + deriving (Eq,Ord,Data,Functor) + +-- | A Module is a pair of a 'Unit' and a 'ModuleName'. +type Module = GenModule Unit + +-- | A 'InstalledModule' is a 'Module' whose unit is identified with an +-- 'UnitId'. +type InstalledModule = GenModule UnitId + +-- | An `InstantiatedModule` is a 'Module' whose unit is identified with an `InstantiatedUnit`. +type InstantiatedModule = GenModule InstantiatedUnit + +type GenInstantiations unit = [(ModuleName,GenModule (GenUnit unit))] +type Instantiations = GenInstantiations UnitId -- | Calculate the free holes of a 'Module'. If this set is non-empty, -- this module was defined in an indefinite library that had required @@ -421,48 +559,44 @@ data Module = Module { -- -- If a module has free holes, that means that substitutions can operate on it; -- if it has no free holes, substituting over a module has no effect. -moduleFreeHoles :: Module -> UniqDSet ModuleName -moduleFreeHoles m - | isHoleModule m = unitUniqDSet (moduleName m) - | otherwise = unitIdFreeHoles (moduleUnitId m) +moduleFreeHoles :: GenModule (GenUnit u) -> UniqDSet ModuleName +moduleFreeHoles (Module HoleUnit name) = unitUniqDSet name +moduleFreeHoles (Module u _ ) = unitFreeModuleHoles u -- | A 'Module' is definite if it has no free holes. moduleIsDefinite :: Module -> Bool moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles --- | Create a module variable at some 'ModuleName'. --- See Note [Representation of module/name variables] -mkHoleModule :: ModuleName -> Module -mkHoleModule = mkModule holeUnitId - instance Uniquable Module where - getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) + getUnique (Module p n) = getUnique (unitFS p `appendFS` moduleNameFS n) instance Outputable Module where ppr = pprModule -instance Binary Module where +instance Outputable InstalledModule where + ppr (Module p n) = + ppr p <> char ':' <> pprModuleName n + +instance Outputable InstantiatedModule where + ppr (Module uid m) = + ppr uid <> char ':' <> ppr m + +instance Binary a => Binary (GenModule a) where put_ bh (Module p n) = put_ bh p >> put_ bh n get bh = do p <- get bh; n <- get bh; return (Module p n) -instance Data Module where - -- don't traverse? - toConstr _ = abstractConstr "Module" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Module" - -instance NFData Module where - rnf x = x `seq` () +instance NFData (GenModule a) where + rnf (Module unit name) = unit `seq` name `seq` () -- | This gives a stable ordering, as opposed to the Ord instance which -- gives an ordering based on the 'Unique's of the components, which may -- not be stable from run to run of the compiler. stableModuleCmp :: Module -> Module -> Ordering stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stableUnitIdCmp` p2) `thenCmp` + = (p1 `stableUnitCmp` p2) `thenCmp` (n1 `stableModuleNameCmp` n2) -mkModule :: UnitId -> ModuleName -> Module +mkModule :: u -> ModuleName -> GenModule u mkModule = Module pprModule :: Module -> SDoc @@ -472,12 +606,12 @@ pprModule mod@(Module p n) = getPprStyle doc | codeStyle sty = (if p == mainUnitId then empty -- never qualify the main package in code - else ztext (zEncodeFS (unitIdFS p)) <> char '_') + else ztext (zEncodeFS (unitFS p)) <> char '_') <> pprModuleName n | qualModule sty mod = - if isHoleModule mod - then angleBrackets (pprModuleName n) - else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n + case p of + HoleUnit -> angleBrackets (pprModuleName n) + _ -> ppr (moduleUnit mod) <> char ':' <> pprModuleName n | otherwise = pprModuleName n @@ -487,179 +621,227 @@ class ContainsModule t where class HasModule m where getModule :: m Module -{- -************************************************************************ -* * -\subsection{ComponentId} -* * -************************************************************************ --} --- | A 'ComponentId' consists of the package name, package version, component --- ID, the transitive dependencies of the component, and other information to --- uniquely identify the source code and build configuration of a component. --- --- This used to be known as an 'InstalledPackageId', but a package can contain --- multiple components and a 'ComponentId' uniquely identifies a component --- within a package. When a package only has one component, the 'ComponentId' --- coincides with the 'InstalledPackageId' -data ComponentId = ComponentId - { componentIdRaw :: FastString -- ^ Raw - , componentIdDetails :: Maybe ComponentDetails -- ^ Cache of component details retrieved from the DB +----------------------------------------------------------------------- +-- IndefUnitId +----------------------------------------------------------------------- + +-- | An 'IndefUnitId' is an 'UnitId' with the invariant that it only +-- refers to an indefinite library; i.e., one that can be instantiated. +type IndefUnitId = Indefinite UnitId + +data Indefinite unit = Indefinite + { indefUnit :: unit -- ^ Unit identifier + , indefUnitPprInfo :: Maybe UnitPprInfo -- ^ Cache for some unit info retrieved from the DB } + deriving (Functor) -instance Eq ComponentId where - a == b = componentIdRaw a == componentIdRaw b +instance Eq unit => Eq (Indefinite unit) where + a == b = indefUnit a == indefUnit b -instance Ord ComponentId where - compare a b = compare (componentIdRaw a) (componentIdRaw b) +instance Ord unit => Ord (Indefinite unit) where + compare a b = compare (indefUnit a) (indefUnit b) -data ComponentDetails = ComponentDetails - { componentPackageName :: String - , componentPackageVersion :: Version - , componentName :: Maybe String - , componentSourcePkdId :: String +-- | Subset of UnitInfo: just enough to pretty-print a unit-id +-- +-- Instead of printing the unit-id which may contain a hash, we print: +-- package-version:componentname +-- +data UnitPprInfo = UnitPprInfo + { unitPprPackageName :: String -- ^ Source package name + , unitPprPackageVersion :: Version -- ^ Source package version + , unitPprComponentName :: Maybe String -- ^ Component name } -instance Uniquable ComponentId where - getUnique (ComponentId n _) = getUnique n +instance Outputable UnitPprInfo where + ppr pprinfo = text $ mconcat + [ unitPprPackageName pprinfo + , case unitPprPackageVersion pprinfo of + Version [] [] -> "" + version -> "-" ++ showVersion version + , case unitPprComponentName pprinfo of + Nothing -> "" + Just cname -> ":" ++ cname + ] + + +instance Uniquable unit => Uniquable (Indefinite unit) where + getUnique (Indefinite n _) = getUnique n -instance Outputable ComponentId where - ppr cid@(ComponentId fs _) = +instance Outputable unit => Outputable (Indefinite unit) where + ppr (Indefinite uid Nothing) = ppr uid + ppr (Indefinite uid (Just pprinfo)) = getPprStyle $ \sty -> if debugStyle sty - then ftext fs - else text (componentIdString cid) + then ppr uid + else ppr pprinfo {- ************************************************************************ * * -\subsection{UnitId} + Unit * * ************************************************************************ -} --- | 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. --- --- There are two possible forms for a 'UnitId'. It can be a --- 'DefiniteUnitId', in which case we just have a string that uniquely --- identifies some fully compiled, installed library we have on disk. --- However, when we are typechecking a library with missing holes, --- we may need to instantiate a library on the fly (in which case --- we don't have any on-disk representation.) In that case, you --- have an 'IndefiniteUnitId', which explicitly records the --- instantiation, so that we can substitute over it. -data UnitId - = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId - | DefiniteUnitId {-# UNPACK #-} !DefUnitId - -unitIdFS :: UnitId -> FastString -unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x -unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x - -unitIdKey :: UnitId -> Unique -unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x -unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x - --- | A unit identifier which identifies an indefinite --- library (with holes) that has been *on-the-fly* instantiated --- with a substitution 'indefUnitIdInsts'. In fact, an indefinite --- unit identifier could have no holes, but we haven't gotten --- around to compiling the actual library yet. +-- | 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. +-- +-- There are two possible forms for a 'Unit': +-- +-- 1) It can be a 'RealUnit', in which case we just have a 'DefUnitId' that +-- uniquely identifies some fully compiled, installed library we have on disk. +-- +-- 2) It can be an 'VirtUnit'. When we are typechecking a library with missing +-- holes, we may need to instantiate a library on the fly (in which case we +-- don't have any on-disk representation.) In that case, you have an +-- 'InstantiatedUnit', which explicitly records the instantiation, so that we +-- can substitute over it. +type Unit = GenUnit UnitId + +data GenUnit unit + = RealUnit !(Definite unit) + -- ^ Installed definite unit (either a fully instantiated unit or a closed unit) + + | VirtUnit !(GenInstantiatedUnit unit) + -- ^ Virtual unit instantiated on-the-fly. It may be definite if all the + -- holes are instantiated but we don't have code objects for it. + + | HoleUnit + -- ^ Fake hole unit + +-- | Map over the unit type of a 'GenUnit' +mapGenUnit :: (u -> v) -> (v -> FastString) -> GenUnit u -> GenUnit v +mapGenUnit f gunitFS = go + where + go gu = case gu of + HoleUnit -> HoleUnit + RealUnit d -> RealUnit (fmap f d) + VirtUnit i -> + VirtUnit $ mkGenInstantiatedUnit gunitFS + (fmap f (instUnitInstanceOf i)) + (fmap (second (fmap go)) (instUnitInsts i)) + +unitFS :: Unit -> FastString +unitFS = genUnitFS unitIdFS + +holeFS :: FastString +holeFS = fsLit "<hole>" + +holeUnique :: Unique +holeUnique = getUnique holeFS + +genUnitFS :: (unit -> FastString) -> GenUnit unit -> FastString +genUnitFS _gunitFS (VirtUnit x) = instUnitFS x +genUnitFS gunitFS (RealUnit (Definite x)) = gunitFS x +genUnitFS _gunitFS HoleUnit = holeFS + +unitKey :: Unit -> Unique +unitKey (VirtUnit x) = instUnitKey x +unitKey (RealUnit (Definite x)) = unitIdKey x +unitKey HoleUnit = holeUnique + +-- | A dynamically instantiated unit. +-- +-- It identifies an indefinite library (with holes) that has been *on-the-fly* +-- instantiated. +-- +-- This unit may be indefinite or not (i.e. with remaining holes or not). In any +-- case, it hasn't been compiled and installed (yet). Nevertheless, we have a +-- mechanism called "improvement" to try to match a fully instantiated unit +-- (i.e. definite, without any remaining hole) with existing compiled and +-- installed units: see Note [VirtUnit to RealUnit improvement]. -- -- An indefinite unit identifier pretty-prints to something like --- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the +-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'IndefUnitId', and the -- brackets enclose the module substitution). -data IndefUnitId - = IndefUnitId { +type InstantiatedUnit = GenInstantiatedUnit UnitId + +data GenInstantiatedUnit unit + = InstantiatedUnit { -- | A private, uniquely identifying representation of - -- a UnitId. This string is completely private to GHC - -- and is just used to get a unique; in particular, we don't use it for - -- symbols (indefinite libraries are not compiled). - indefUnitIdFS :: FastString, - -- | Cached unique of 'unitIdFS'. - indefUnitIdKey :: Unique, - -- | The component identity of the indefinite library that - -- is being instantiated. - indefUnitIdComponentId :: !ComponentId, - -- | The sorted (by 'ModuleName') instantiations of this library. - indefUnitIdInsts :: ![(ModuleName, Module)], - -- | A cache of the free module variables of 'unitIdInsts'. - -- This lets us efficiently tell if a 'UnitId' has been - -- fully instantiated (free module variables are empty) + -- an InstantiatedUnit. This string is completely private to GHC + -- and is just used to get a unique. + instUnitFS :: FastString, + -- | Cached unique of 'unitFS'. + instUnitKey :: Unique, + -- | The indefinite unit being instantiated. + instUnitInstanceOf :: !(Indefinite unit), + -- | The sorted (by 'ModuleName') instantiations of this unit. + instUnitInsts :: !(GenInstantiations unit), + -- | A cache of the free module holes of 'instUnitInsts'. + -- This lets us efficiently tell if a 'InstantiatedUnit' has been + -- fully instantiated (empty set of free module holes) -- and whether or not a substitution can have any effect. - indefUnitIdFreeHoles :: UniqDSet ModuleName + instUnitHoles :: UniqDSet ModuleName } -instance Eq IndefUnitId where - u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 +instance Eq InstantiatedUnit where + u1 == u2 = instUnitKey u1 == instUnitKey u2 -instance Ord IndefUnitId where - u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 +instance Ord InstantiatedUnit where + u1 `compare` u2 = instUnitFS u1 `compare` instUnitFS u2 -instance Binary IndefUnitId where +instance Binary InstantiatedUnit where put_ bh indef = do - put_ bh (indefUnitIdComponentId indef) - put_ bh (indefUnitIdInsts indef) + put_ bh (instUnitInstanceOf indef) + put_ bh (instUnitInsts indef) get bh = do cid <- get bh insts <- get bh - let fs = hashUnitId cid insts - return IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs + let fs = mkInstantiatedUnitHash cid insts + return InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs } --- | Create a new 'IndefUnitId' given an explicit module substitution. -newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId -newIndefUnitId cid insts = - IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = sorted_insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs +-- | Create a new 'GenInstantiatedUnit' given an explicit module substitution. +mkGenInstantiatedUnit :: (unit -> FastString) -> Indefinite unit -> GenInstantiations unit -> GenInstantiatedUnit unit +mkGenInstantiatedUnit gunitFS cid insts = + InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = sorted_insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs } where - fs = hashUnitId cid sorted_insts + fs = mkGenInstantiatedUnitHash gunitFS cid sorted_insts sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts --- | Injects an 'IndefUnitId' (indefinite library which --- was on-the-fly instantiated) to a 'UnitId' (either --- an indefinite or definite library). -indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId -indefUnitIdToUnitId dflags iuid = +-- | Create a new 'InstantiatedUnit' given an explicit module substitution. +mkInstantiatedUnit :: IndefUnitId -> Instantiations -> InstantiatedUnit +mkInstantiatedUnit = mkGenInstantiatedUnit unitIdFS + +-- | Check the database to see if we already have an installed unit that +-- corresponds to the given 'InstantiatedUnit'. +-- +-- Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged or +-- references a matching installed unit. +-- +-- See Note [VirtUnit to RealUnit improvement] +instUnitToUnit :: PackageState -> InstantiatedUnit -> Unit +instUnitToUnit pkgstate iuid = -- NB: suppose that we want to compare the indefinite -- unit id p[H=impl:H] against p+abcd (where p+abcd -- happens to be the existing, installed version of -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] - -- IndefiniteUnitId, they won't compare equal; only + -- VirtUnit, they won't compare equal; only -- after improvement will the equality hold. - improveUnitId (getUnitInfoMap dflags) $ - IndefiniteUnitId iuid - -data IndefModule = IndefModule { - indefModuleUnitId :: IndefUnitId, - indefModuleName :: ModuleName - } deriving (Eq, Ord) - -instance Outputable IndefModule where - ppr (IndefModule uid m) = - ppr uid <> char ':' <> ppr m + improveUnit (unitInfoMap pkgstate) $ + VirtUnit iuid --- | Injects an 'IndefModule' to 'Module' (see also --- 'indefUnitIdToUnitId'. -indefModuleToModule :: DynFlags -> IndefModule -> Module -indefModuleToModule dflags (IndefModule iuid mod_name) = - mkModule (indefUnitIdToUnitId dflags iuid) mod_name +-- | Injects an 'InstantiatedModule' to 'Module' (see also +-- 'instUnitToUnit'. +instModuleToModule :: PackageState -> InstantiatedModule -> Module +instModuleToModule pkgstate (Module iuid mod_name) = + mkModule (instUnitToUnit pkgstate iuid) mod_name -- | An installed unit identifier identifies a library which has -- been installed to the package database. These strings are @@ -671,47 +853,48 @@ indefModuleToModule dflags (IndefModule iuid mod_name) = -- -- Installed unit identifiers look something like @p+af23SAj2dZ219@, -- or maybe just @p@ if they don't use Backpack. -newtype InstalledUnitId = - InstalledUnitId { +newtype UnitId = + UnitId { -- | The full hashed unit identifier, including the component id -- and the hash. - installedUnitIdFS :: FastString + unitIdFS :: FastString } -instance Binary InstalledUnitId where - put_ bh (InstalledUnitId fs) = put_ bh fs - get bh = do fs <- get bh; return (InstalledUnitId fs) +instance Binary UnitId where + put_ bh (UnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (UnitId fs) -instance Eq InstalledUnitId where - uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 +instance Eq UnitId where + uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 -instance Ord InstalledUnitId where - u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 +instance Ord UnitId where + u1 `compare` u2 = unitIdFS u1 `compare` unitIdFS u2 -instance Uniquable InstalledUnitId where - getUnique = installedUnitIdKey +instance Uniquable UnitId where + getUnique = unitIdKey -instance Outputable InstalledUnitId where - ppr uid@(InstalledUnitId fs) = +instance Outputable UnitId where + ppr uid@(UnitId fs) = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags -> - case displayInstalledUnitId (getPackageState dflags) uid of + case displayUnitId (getPackageState dflags) uid of Just str | not (debugStyle sty) -> text str _ -> ftext fs -installedUnitIdKey :: InstalledUnitId -> Unique -installedUnitIdKey = getUnique . installedUnitIdFS +unitIdKey :: UnitId -> Unique +unitIdKey = getUnique . unitIdFS --- | Lossy conversion to the on-disk 'InstalledUnitId' for a component. -toInstalledUnitId :: UnitId -> InstalledUnitId -toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid -toInstalledUnitId (IndefiniteUnitId indef) = - componentIdToInstalledUnitId (indefUnitIdComponentId indef) +-- | Return the UnitId of the Unit. For instantiated units, return the +-- UnitId of the indefinite unit this unit is an instance of. +toUnitId :: Unit -> UnitId +toUnitId (RealUnit (Definite iuid)) = iuid +toUnitId (VirtUnit indef) = indefUnit (instUnitInstanceOf indef) +toUnitId HoleUnit = error "Hole unit" -installedUnitIdString :: InstalledUnitId -> String -installedUnitIdString = unpackFS . installedUnitIdFS +unitIdString :: UnitId -> String +unitIdString = unpackFS . unitIdFS -instance Outputable IndefUnitId where +instance Outputable InstantiatedUnit where ppr uid = -- getPprStyle $ \sty -> ppr cid <> @@ -723,53 +906,41 @@ instance Outputable IndefUnitId where | (modname, m) <- insts])) else empty) where - cid = indefUnitIdComponentId uid - insts = indefUnitIdInsts uid - --- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. -data InstalledModule = InstalledModule { - installedModuleUnitId :: !InstalledUnitId, - installedModuleName :: !ModuleName - } - deriving (Eq, Ord) + cid = instUnitInstanceOf uid + insts = instUnitInsts uid -instance Outputable InstalledModule where - ppr (InstalledModule p n) = - ppr p <> char ':' <> pprModuleName n - -fsToInstalledUnitId :: FastString -> InstalledUnitId -fsToInstalledUnitId fs = InstalledUnitId fs - -componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId -componentIdToInstalledUnitId (ComponentId fs _) = fsToInstalledUnitId fs +fsToUnitId :: FastString -> UnitId +fsToUnitId fs = UnitId fs -stringToInstalledUnitId :: String -> InstalledUnitId -stringToInstalledUnitId = fsToInstalledUnitId . mkFastString +stringToUnitId :: String -> UnitId +stringToUnitId = fsToUnitId . mkFastString -- | Test if a 'Module' corresponds to a given 'InstalledModule', -- modulo instantiation. installedModuleEq :: InstalledModule -> Module -> Bool installedModuleEq imod mod = - fst (splitModuleInsts mod) == imod + fst (getModuleInstantiation mod) == imod --- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', +-- | Test if a 'Unit' corresponds to a given 'UnitId', -- modulo instantiation. -installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool -installedUnitIdEq iuid uid = - fst (splitUnitIdInsts uid) == iuid +unitIdEq :: UnitId -> Unit -> Bool +unitIdEq iuid uid = toUnitId uid == iuid --- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that +-- | A 'DefUnitId' is an 'UnitId' with the invariant that -- it only refers to a definite library; i.e., one we have generated -- code for. -newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } - deriving (Eq, Ord) +type DefUnitId = Definite UnitId -instance Outputable DefUnitId where - ppr (DefUnitId uid) = ppr uid +-- | A definite unit (i.e. without any free module hole) +newtype Definite unit = Definite { unDefinite :: unit } + deriving (Eq, Ord, Functor) -instance Binary DefUnitId where - put_ bh (DefUnitId uid) = put_ bh uid - get bh = do uid <- get bh; return (DefUnitId uid) +instance Outputable unit => Outputable (Definite unit) where + ppr (Definite uid) = ppr uid + +instance Binary unit => Binary (Definite unit) where + put_ bh (Definite uid) = put_ bh uid + get bh = do uid <- get bh; return (Definite uid) -- | A map keyed off of 'InstalledModule' newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) @@ -790,21 +961,22 @@ filterInstalledModuleEnv f (InstalledModuleEnv e) = delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) --- Note [UnitId to InstalledUnitId improvement] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Just because a UnitId is definite (has no holes) doesn't --- mean it's necessarily a InstalledUnitId; it could just be --- that over the course of renaming UnitIds on the fly --- while typechecking an indefinite library, we --- ended up with a fully instantiated unit id with no hash, --- since we haven't built it yet. This is fine. --- --- However, if there is a hashed unit id for this instantiation --- in the package database, we *better use it*, because --- that hashed unit id may be lurking in another interface, --- and chaos will ensue if we attempt to compare the two --- (the unitIdFS for a UnitId never corresponds to a Cabal-provided --- hash of a compiled instantiated library). +-- Note [VirtUnit to RealUnit improvement] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Over the course of instantiating VirtUnits on the fly while typechecking an +-- indefinite library, we may end up with a fully instantiated VirtUnit. I.e. +-- one that could be compiled and installed in the database. During +-- type-checking we generate a virtual UnitId for it, say "abc". +-- +-- Now the question is: do we have a matching installed unit in the database? +-- Suppose we have one with UnitId "xyz" (provided by Cabal so we don't know how +-- to generate it). The trouble is that if both units end up being used in the +-- same type-checking session, their names won't match (e.g. "abc:M.X" vs +-- "xyz:M.X"). +-- +-- As we want them to match we just replace the virtual unit with the installed +-- one: for some reason this is called "improvement". -- -- There is one last niggle: improvement based on the package database means -- that we might end up developing on a package that is not transitively @@ -814,39 +986,46 @@ delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete -- unit id if the new unit id is part of the 'preloadClosure'; i.e., the -- closure of all the packages which were explicitly specified. --- | Retrieve the set of free holes of a 'UnitId'. -unitIdFreeHoles :: UnitId -> UniqDSet ModuleName -unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x +-- | Retrieve the set of free module holes of a 'Unit'. +unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName +unitFreeModuleHoles (VirtUnit x) = instUnitHoles x -- Hashed unit ids are always fully instantiated -unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet - -instance Show UnitId where - show = unitIdString - --- | A 'UnitId' is definite if it has no free holes. -unitIdIsDefinite :: UnitId -> Bool -unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles - --- | Generate a uniquely identifying 'FastString' for a unit --- identifier. This is a one-way function. You can rely on one special --- property: if a unit identifier is in most general form, its 'FastString' --- coincides with its 'ComponentId'. This hash is completely internal --- to GHC and is not used for symbol names or file paths. -hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString -hashUnitId cid sorted_holes = +unitFreeModuleHoles (RealUnit _) = emptyUniqDSet +unitFreeModuleHoles HoleUnit = emptyUniqDSet + +instance Show Unit where + show = unitString + +-- | A 'Unit' is definite if it has no free holes. +unitIsDefinite :: Unit -> Bool +unitIsDefinite = isEmptyUniqDSet . unitFreeModuleHoles + +-- | Generate a uniquely identifying hash (internal unit-id) for an instantiated +-- unit. +-- +-- This is a one-way function. If the indefinite unit has not been instantiated at all, we return its unit-id. +-- +-- 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 = mkFastStringByteString - . fingerprintUnitId (bytesFS (componentIdRaw cid)) - $ rawHashUnitId sorted_holes + . fingerprintUnitId (bytesFS (gunitFS (indefUnit cid))) + $ hashInstantiations gunitFS sorted_holes --- | Generate a hash for a sorted module substitution. -rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint -rawHashUnitId sorted_holes = +mkInstantiatedUnitHash :: IndefUnitId -> Instantiations -> FastString +mkInstantiatedUnitHash = mkGenInstantiatedUnitHash unitIdFS + +-- | Generate a hash for a sorted module instantiation. +hashInstantiations :: (unit -> FastString) -> [(ModuleName, GenModule (GenUnit unit))] -> Fingerprint +hashInstantiations gunitFS sorted_holes = fingerprintByteString . BS.concat $ do (m, b) <- sorted_holes - [ bytesFS (moduleNameFS m), BS.Char8.singleton ' ', - bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', - bytesFS (moduleNameFS (moduleName b)), BS.Char8.singleton '\n'] + [ bytesFS (moduleNameFS m), BS.Char8.singleton ' ', + bytesFS (genUnitFS gunitFS (moduleUnit b)), BS.Char8.singleton ':', + bytesFS (moduleNameFS (moduleName b)), BS.Char8.singleton '\n'] fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString fingerprintUnitId prefix (Fingerprint a b) @@ -856,71 +1035,75 @@ fingerprintUnitId prefix (Fingerprint a b) , BS.Char8.pack (toBase62Padded a) , BS.Char8.pack (toBase62Padded b) ] --- | Create a new, un-hashed unit identifier. -newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId -newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... -newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts +-- | 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 -pprUnitId :: UnitId -> SDoc -pprUnitId (DefiniteUnitId uid) = ppr uid -pprUnitId (IndefiniteUnitId uid) = ppr uid +-- | Smart constructor for VirtUnit +mkVirtUnit :: IndefUnitId -> Instantiations -> Unit +mkVirtUnit = mkGenVirtUnit unitIdFS -instance Eq UnitId where - uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 +pprUnit :: Unit -> SDoc +pprUnit (RealUnit uid) = ppr uid +pprUnit (VirtUnit uid) = ppr uid +pprUnit HoleUnit = ftext holeFS -instance Uniquable UnitId where - getUnique = unitIdKey +instance Eq Unit where + uid1 == uid2 = unitKey uid1 == unitKey uid2 -instance Ord UnitId where - nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 +instance Uniquable Unit where + getUnique = unitKey + +instance Ord Unit where + nm1 `compare` nm2 = stableUnitCmp nm1 nm2 -instance Data UnitId where +instance Data Unit where -- don't traverse? - toConstr _ = abstractConstr "UnitId" + toConstr _ = abstractConstr "Unit" gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "UnitId" + dataTypeOf _ = mkNoRepType "Unit" -instance NFData UnitId where +instance NFData Unit where rnf x = x `seq` () -stableUnitIdCmp :: UnitId -> UnitId -> Ordering --- ^ Compares package ids lexically, rather than by their 'Unique's -stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 +-- | Compares unit ids lexically, rather than by their 'Unique's +stableUnitCmp :: Unit -> Unit -> Ordering +stableUnitCmp p1 p2 = unitFS p1 `compare` unitFS p2 -instance Outputable UnitId where - ppr pk = pprUnitId pk +instance Outputable Unit where + ppr pk = pprUnit pk -- Performance: would prefer to have a NameCache like thing -instance Binary UnitId where - put_ bh (DefiniteUnitId def_uid) = do +instance Binary Unit where + put_ bh (RealUnit def_uid) = do putByte bh 0 put_ bh def_uid - put_ bh (IndefiniteUnitId indef_uid) = do + put_ bh (VirtUnit indef_uid) = do putByte bh 1 put_ bh indef_uid + put_ bh HoleUnit = do + putByte bh 2 get bh = do b <- getByte bh case b of - 0 -> fmap DefiniteUnitId (get bh) - _ -> fmap IndefiniteUnitId (get bh) + 0 -> fmap RealUnit (get bh) + 1 -> fmap VirtUnit (get bh) + _ -> pure HoleUnit -instance Binary ComponentId where - put_ bh (ComponentId fs _) = put_ bh fs - get bh = do { fs <- get bh; return (ComponentId fs Nothing) } - --- | Create a new simple unit identifier (no holes) from a 'ComponentId'. -newSimpleUnitId :: ComponentId -> UnitId -newSimpleUnitId (ComponentId fs _) = fsToUnitId fs +instance Binary unit => Binary (Indefinite unit) where + put_ bh (Indefinite fs _) = put_ bh fs + get bh = do { fs <- get bh; return (Indefinite fs Nothing) } -- | Create a new simple unit identifier from a 'FastString'. Internally, -- this is primarily used to specify wired-in unit identifiers. -fsToUnitId :: FastString -> UnitId -fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId +fsToUnit :: FastString -> Unit +fsToUnit = RealUnit . Definite . UnitId -stringToUnitId :: String -> UnitId -stringToUnitId = fsToUnitId . mkFastString +stringToUnit :: String -> Unit +stringToUnit = fsToUnit . mkFastString -unitIdString :: UnitId -> String -unitIdString = unpackFS . unitIdFS +unitString :: Unit -> String +unitString = unpackFS . unitFS {- ************************************************************************ @@ -941,41 +1124,41 @@ type ShHoleSubst = ModuleNameEnv Module renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module renameHoleModule dflags = renameHoleModule' (getUnitInfoMap dflags) --- | Substitutes holes in a 'UnitId', suitable for renaming when +-- | Substitutes holes in a 'Unit', suitable for renaming when -- an include occurs; see Note [Representation of module/name variable]. -- -- @p[A=<A>]@ maps to @p[A=<B>]@ with @A=<B>@. -renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId dflags = renameHoleUnitId' (getUnitInfoMap dflags) +renameHoleUnit :: DynFlags -> ShHoleSubst -> Unit -> Unit +renameHoleUnit dflags = renameHoleUnit' (getUnitInfoMap dflags) -- | Like 'renameHoleModule', but requires only 'UnitInfoMap' -- so it can be used by "Packages". renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module renameHoleModule' pkg_map env m | not (isHoleModule m) = - let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) + let uid = renameHoleUnit' pkg_map env (moduleUnit m) in mkModule uid (moduleName m) | Just m' <- lookupUFM env (moduleName m) = m' -- NB m = <Blah>, that's what's in scope. | otherwise = m --- | Like 'renameHoleUnitId, but requires only 'UnitInfoMap' +-- | Like 'renameHoleUnit, but requires only 'UnitInfoMap' -- so it can be used by "Packages". -renameHoleUnitId' :: UnitInfoMap -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId' pkg_map env uid = +renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit +renameHoleUnit' pkg_map env uid = case uid of - (IndefiniteUnitId - IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts - , indefUnitIdFreeHoles = fh }) + (VirtUnit + InstantiatedUnit{ instUnitInstanceOf = cid + , instUnitInsts = insts + , instUnitHoles = fh }) -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) then uid -- Functorially apply the substitution to the instantiation, -- then check the 'UnitInfoMap' to see if there is - -- a compiled version of this 'UnitId' we can improve to. - -- See Note [UnitId to InstalledUnitId] improvement - else improveUnitId pkg_map $ - newUnitId cid + -- a compiled version of this 'InstantiatedUnit' we can improve to. + -- See Note [VirtUnit to RealUnit improvement] + else improveUnit pkg_map $ + mkVirtUnit cid (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) _ -> uid @@ -983,68 +1166,74 @@ renameHoleUnitId' pkg_map env uid = -- a 'Module' that we definitely can find on-disk, as well as an -- instantiation if we need to instantiate it on the fly. If the -- instantiation is @Nothing@ no on-the-fly renaming is needed. -splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule) -splitModuleInsts m = - let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m) - in (InstalledModule uid (moduleName m), - fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid) - --- | See 'splitModuleInsts'. -splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId) -splitUnitIdInsts (IndefiniteUnitId iuid) = - (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid) -splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) - -generalizeIndefUnitId :: IndefUnitId -> IndefUnitId -generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts } = - newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) - -generalizeIndefModule :: IndefModule -> IndefModule -generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n +getModuleInstantiation :: Module -> (InstalledModule, Maybe InstantiatedModule) +getModuleInstantiation m = + let (uid, mb_iuid) = getUnitInstantiations (moduleUnit m) + in (Module uid (moduleName m), + fmap (\iuid -> Module iuid (moduleName m)) mb_iuid) + +-- | Return the unit-id this unit is an instance of and the module instantiations (if any). +getUnitInstantiations :: Unit -> (UnitId, Maybe InstantiatedUnit) +getUnitInstantiations (VirtUnit iuid) = (indefUnit (instUnitInstanceOf iuid), Just iuid) +getUnitInstantiations (RealUnit (Definite uid)) = (uid, Nothing) +getUnitInstantiations HoleUnit = error "Hole unit" + +-- | Remove instantiations of the given instantiated unit +uninstantiateInstantiatedUnit :: InstantiatedUnit -> InstantiatedUnit +uninstantiateInstantiatedUnit u = + mkInstantiatedUnit (instUnitInstanceOf u) + (map (\(m,_) -> (m, mkHoleModule m)) + (instUnitInsts u)) + +-- | Remove instantiations of the given module instantiated unit +uninstantiateInstantiatedModule :: InstantiatedModule -> InstantiatedModule +uninstantiateInstantiatedModule (Module uid n) = Module (uninstantiateInstantiatedUnit uid) n parseModuleName :: ReadP ModuleName parseModuleName = fmap mkModuleName $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") -parseUnitId :: ReadP UnitId -parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId +parseUnit :: ReadP Unit +parseUnit = parseVirtUnitId <++ parseDefUnitId where - parseFullUnitId = do - cid <- parseComponentId + parseVirtUnitId = do + uid <- parseIndefUnitId insts <- parseModSubst - return (newUnitId cid insts) - parseDefiniteUnitId = do - s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") - return (stringToUnitId s) - parseSimpleUnitId = do - cid <- parseComponentId - return (newSimpleUnitId cid) - -parseComponentId :: ReadP ComponentId -parseComponentId = (flip ComponentId Nothing . mkFastString) `fmap` Parse.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." - -parseModuleId :: ReadP Module -parseModuleId = parseModuleVar <++ parseModule + return (mkVirtUnit uid insts) + parseDefUnitId = do + s <- parseUnitId + return (RealUnit (Definite s)) + +parseUnitId :: ReadP UnitId +parseUnitId = do + s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + return (UnitId (mkFastString s)) + +parseIndefUnitId :: ReadP IndefUnitId +parseIndefUnitId = do + uid <- parseUnitId + return (Indefinite uid Nothing) + +parseHoleyModule :: ReadP Module +parseHoleyModule = parseModuleVar <++ parseModule where parseModuleVar = do _ <- Parse.char '<' modname <- parseModuleName _ <- Parse.char '>' - return (mkHoleModule modname) + return (Module HoleUnit modname) parseModule = do - uid <- parseUnitId + uid <- parseUnit _ <- Parse.char ':' modname <- parseModuleName - return (mkModule uid modname) + return (Module uid modname) parseModSubst :: ReadP [(ModuleName, Module)] parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') . flip Parse.sepBy (Parse.char ',') $ do k <- parseModuleName _ <- Parse.char '=' - v <- parseModuleId + v <- parseHoleyModule return (k, v) @@ -1083,37 +1272,30 @@ See Note [The integer library] in GHC.Builtin.Names. integerUnitId, primUnitId, baseUnitId, rtsUnitId, - thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId -primUnitId = fsToUnitId (fsLit "ghc-prim") -integerUnitId = fsToUnitId (fsLit "integer-wired-in") + thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: Unit +primUnitId = fsToUnit (fsLit "ghc-prim") +integerUnitId = fsToUnit (fsLit "integer-wired-in") -- See Note [The integer library] in GHC.Builtin.Names -baseUnitId = fsToUnitId (fsLit "base") -rtsUnitId = fsToUnitId (fsLit "rts") -thUnitId = fsToUnitId (fsLit "template-haskell") -thisGhcUnitId = fsToUnitId (fsLit "ghc") -interactiveUnitId = fsToUnitId (fsLit "interactive") +baseUnitId = fsToUnit (fsLit "base") +rtsUnitId = fsToUnit (fsLit "rts") +thUnitId = fsToUnit (fsLit "template-haskell") +thisGhcUnitId = fsToUnit (fsLit "ghc") +interactiveUnitId = fsToUnit (fsLit "interactive") -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix -- to symbol names, since there can be only one main package per program. -mainUnitId = fsToUnitId (fsLit "main") - --- | This is a fake package id used to provide identities to any un-implemented --- signatures. The set of hole identities is global over an entire compilation. --- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. --- See Note [Representation of module/name variables] -holeUnitId :: UnitId -holeUnitId = fsToUnitId (fsLit "hole") +mainUnitId = fsToUnit (fsLit "main") isInteractiveModule :: Module -> Bool -isInteractiveModule mod = moduleUnitId mod == interactiveUnitId +isInteractiveModule mod = moduleUnit mod == interactiveUnitId -- Note [Representation of module/name variables] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent -- name holes. This could have been represented by adding some new cases --- to the core data types, but this would have made the existing 'nameModule' --- and 'moduleUnitId' partial, which would have required a lot of modifications +-- to the core data types, but this would have made the existing 'moduleName' +-- and 'moduleUnit' partial, which would have required a lot of modifications -- to existing code. -- -- Instead, we adopted the following encoding scheme: @@ -1125,13 +1307,19 @@ isInteractiveModule mod = moduleUnitId mod == interactiveUnitId -- because if you have a 'hole:A' you need to know if it's actually a -- 'Module' or just a module stored in a 'Name'; these two cases must be -- treated differently when doing substitutions. 'renameHoleModule' --- and 'renameHoleUnitId' assume they are NOT operating on a +-- and 'renameHoleUnit' assume they are NOT operating on a -- 'Name'; 'NameShape' handles name substitutions exclusively. -isHoleModule :: Module -> Bool -isHoleModule mod = moduleUnitId mod == holeUnitId +-- | Test if a Module is not instantiated +isHoleModule :: GenModule (GenUnit u) -> Bool +isHoleModule (Module HoleUnit _) = True +isHoleModule _ = False + +-- | Create a hole Module +mkHoleModule :: ModuleName -> GenModule (GenUnit u) +mkHoleModule = Module HoleUnit -wiredInUnitIds :: [UnitId] +wiredInUnitIds :: [Unit] wiredInUnitIds = [ primUnitId, integerUnitId, baseUnitId, diff --git a/compiler/GHC/Types/Module.hs-boot b/compiler/GHC/Types/Module.hs-boot index 5d30a94f32..7846cb795d 100644 --- a/compiler/GHC/Types/Module.hs-boot +++ b/compiler/GHC/Types/Module.hs-boot @@ -2,12 +2,16 @@ module GHC.Types.Module where import GHC.Prelude -data Module data ModuleName data UnitId -data InstalledUnitId -data ComponentId +data GenModule a +data GenUnit a +data Indefinite unit -moduleName :: Module -> ModuleName -moduleUnitId :: Module -> UnitId -unitIdString :: UnitId -> String +type Unit = GenUnit UnitId +type IndefUnitId = Indefinite UnitId +type Module = GenModule Unit + +moduleName :: GenModule a -> ModuleName +moduleUnit :: GenModule a -> a +unitString :: Unit -> String diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index 691a198167..2525d8b12b 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -282,12 +282,12 @@ nameIsHomePackage :: Module -> Name -> Bool -- True if the Name is defined in module of this package nameIsHomePackage this_mod = \nm -> case n_sort nm of - External nm_mod -> moduleUnitId nm_mod == this_pkg - WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg + External nm_mod -> moduleUnit nm_mod == this_pkg + WiredIn nm_mod _ _ -> moduleUnit nm_mod == this_pkg Internal -> True System -> False where - this_pkg = moduleUnitId this_mod + this_pkg = moduleUnit this_mod nameIsHomePackageImport :: Module -> Name -> Bool -- True if the Name is defined in module of this package @@ -296,17 +296,17 @@ nameIsHomePackageImport this_mod = \nm -> case nameModule_maybe nm of Nothing -> False Just nm_mod -> nm_mod /= this_mod - && moduleUnitId nm_mod == this_pkg + && moduleUnit nm_mod == this_pkg where - this_pkg = moduleUnitId this_mod + this_pkg = moduleUnit this_mod -- | Returns True if the Name comes from some other package: neither this -- package nor the interactive package. -nameIsFromExternalPackage :: UnitId -> Name -> Bool -nameIsFromExternalPackage this_pkg name +nameIsFromExternalPackage :: Unit -> Name -> Bool +nameIsFromExternalPackage this_unit name | Just mod <- nameModule_maybe name - , moduleUnitId mod /= this_pkg -- Not this package - , not (isInteractiveModule mod) -- Not the 'interactive' package + , moduleUnit mod /= this_unit -- Not the current unit + , not (isInteractiveModule mod) -- Not the 'interactive' package = True | otherwise = False @@ -592,7 +592,7 @@ pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ case qualName sty mod occ of -- See Outputable.QualifyName: NameQual modname -> ppr modname <> dot -- Name is in scope NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in + NameNotInScope2 -> ppr (moduleUnit mod) <> colon -- Module not in <> ppr (moduleName mod) <> dot -- scope either NameUnqual -> empty -- In scope unqualified diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs index c7bfd98152..745fe8bb77 100644 --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -160,7 +160,7 @@ ns_module = mkHoleModule . ns_mod_name -} -- | Substitution on @{A.T}@. We enforce the invariant that the --- 'nameModule' of keys of this map have 'moduleUnitId' @hole@ +-- 'nameModule' of keys of this map have 'moduleUnit' @hole@ -- (meaning that if we have a hole substitution, the keys of the map -- are never affected.) Alternatively, this is isomorphic to -- @Map ('ModuleName', 'OccName') 'Name'@. diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs index 8a6558f94c..d0014bc3e1 100644 --- a/compiler/GHC/Unit/Info.hs +++ b/compiler/GHC/Unit/Info.hs @@ -6,27 +6,27 @@ -- -- (c) The University of Glasgow, 2004 -- -module GHC.Unit.Info ( - -- $package_naming - - -- * UnitId - packageConfigId, - expandedUnitInfoId, - definiteUnitInfoId, - installedUnitInfoId, - - -- * The UnitInfo type: information about a unit - UnitInfo, - toUnitInfo, - GenericUnitInfo(..), - ComponentId(..), - PackageId(..), - PackageName(..), - Version(..), - unitPackageNameString, - unitPackageIdString, - pprUnitInfo, - ) where +module GHC.Unit.Info + ( GenericUnitInfo (..) + , GenUnitInfo + , UnitInfo + , UnitKey (..) + , UnitKeyInfo + , mkUnitKeyInfo + , mapUnitInfo + + , mkUnit + , expandedUnitInfoId + , definiteUnitInfoId + + , PackageId(..) + , PackageName(..) + , Version(..) + , unitPackageNameString + , unitPackageIdString + , pprUnitInfo + ) +where #include "HsVersions.h" @@ -41,40 +41,61 @@ import GHC.Utils.Outputable import GHC.Types.Module as Module import GHC.Types.Unique --- ----------------------------------------------------------------------------- --- Our UnitInfo type is the GenericUnitInfo from ghc-boot, --- which is similar to a subset of the InstalledPackageInfo type from Cabal. - -type UnitInfo = GenericUnitInfo - ComponentId - PackageId - PackageName - Module.InstalledUnitId - Module.ModuleName - Module.Module - --- | Convert a DbUnitInfo (read from a package database) into `UnitInfo` -toUnitInfo :: DbUnitInfo -> UnitInfo -toUnitInfo = mapGenericUnitInfo - mkUnitId' - mkComponentId' +-- | Information about an installed unit +-- +-- We parameterize on the unit identifier: +-- * UnitKey: identifier used in the database (cf 'UnitKeyInfo') +-- * UnitId: identifier used to generate code (cf 'UnitInfo') +-- +-- These two identifiers are different for wired-in packages. See Note [The +-- identifier lexicon] in GHC.Types.Module +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 + +-- | Information about an installed unit (units are identified by their internal +-- UnitId) +type UnitInfo = GenUnitInfo UnitId + +-- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo` +mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo +mkUnitKeyInfo = mapGenericUnitInfo + mkUnitKey' + mkIndefUnitKey' mkPackageIdentifier' mkPackageName' mkModuleName' mkModule' where - mkPackageIdentifier' = PackageId . mkFastStringByteString - mkPackageName' = PackageName . mkFastStringByteString - mkUnitId' = InstalledUnitId . mkFastStringByteString - mkModuleName' = mkModuleNameFS . mkFastStringByteString - mkComponentId' cid = ComponentId (mkFastStringByteString cid) Nothing - mkInstUnitId' i = case i of - DbInstUnitId cid insts -> newUnitId (mkComponentId' cid) (fmap (bimap mkModuleName' mkModule') insts) - DbUnitId uid -> DefiniteUnitId (DefUnitId (mkUnitId' uid)) + mkPackageIdentifier' = PackageId . mkFastStringByteString + mkPackageName' = PackageName . mkFastStringByteString + mkUnitKey' = UnitKey . mkFastStringByteString + 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) + DbUnitId uid -> RealUnit (Definite (mkUnitKey' uid)) mkModule' m = case m of - DbModule uid n -> mkModule (mkInstUnitId' uid) (mkModuleName' n) + 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 + f -- unit identifier + (fmap f) -- indefinite unit identifier + id -- package identifier + id -- package name + id -- module name + (fmap (mapGenUnit f gunitFS)) -- 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 @@ -137,33 +158,18 @@ pprUnitInfo GenericUnitInfo {..} = where field name body = text name <> colon <+> nest 4 body --- ----------------------------------------------------------------------------- --- UnitId (package names, versions and dep hash) - --- $package_naming --- #package_naming# --- Mostly the compiler deals in terms of 'UnitId's, which are md5 hashes --- of a package ID, keys of its dependencies, and Cabal flags. You're expected --- to pass in the unit id in the @-this-unit-id@ flag. However, for --- wired-in packages like @base@ & @rts@, we don't necessarily know what the --- version is, so these are handled specially; see #wired_in_packages#. - --- | Get the GHC 'UnitId' right out of a Cabalish 'UnitInfo' -installedUnitInfoId :: UnitInfo -> InstalledUnitId -installedUnitInfoId = unitId - -packageConfigId :: UnitInfo -> UnitId -packageConfigId p = +mkUnit :: UnitInfo -> Unit +mkUnit p = if unitIsIndefinite p - then newUnitId (unitInstanceOf p) (unitInstantiations p) - else DefiniteUnitId (DefUnitId (unitId p)) + then mkVirtUnit (unitInstanceOf p) (unitInstantiations p) + else RealUnit (Definite (unitId p)) -expandedUnitInfoId :: UnitInfo -> UnitId +expandedUnitInfoId :: UnitInfo -> Unit expandedUnitInfoId p = - newUnitId (unitInstanceOf p) (unitInstantiations p) + mkVirtUnit (unitInstanceOf p) (unitInstantiations p) definiteUnitInfoId :: UnitInfo -> Maybe DefUnitId definiteUnitInfoId p = - case packageConfigId p of - DefiniteUnitId def_uid -> Just def_uid - _ -> Nothing + case mkUnit p of + RealUnit def_uid -> Just def_uid + _ -> Nothing diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 178ac58818..bcea799bd8 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -99,7 +99,7 @@ import {-# SOURCE #-} GHC.Driver.Session , pprUserLength , unsafeGlobalDynFlags, initSDocContext ) -import {-# SOURCE #-} GHC.Types.Module( UnitId, Module, ModuleName, moduleName ) +import {-# SOURCE #-} GHC.Types.Module( Unit, Module, ModuleName, moduleName ) import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import GHC.Utils.BufHandle (BufHandle) @@ -196,7 +196,7 @@ type QueryQualifyModule = Module -> Bool -- | For a given package, we need to know whether to print it with -- the component id to disambiguate it. -type QueryQualifyPackage = UnitId -> Bool +type QueryQualifyPackage = Unit -> Bool -- See Note [Printing original names] in GHC.Driver.Types data QualifyName -- Given P:M.T diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 0da9741f30..3006af68c1 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -57,7 +57,7 @@ import GHC.Driver.Types ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_dynLinker, hsc_interp ) import GHC.Types.Module import GHC.Types.Name -import GHC.Driver.Packages ( unitIsTrusted, getPackageDetails, getInstalledPackageDetails, +import GHC.Driver.Packages ( unitIsTrusted, unsafeGetUnitInfo, getInstalledPackageDetails, listVisibleModuleNames, pprFlag ) import GHC.Iface.Syntax ( showToHeader ) import GHC.Core.Ppr.TyThing @@ -2340,8 +2340,8 @@ isSafeModule m = do mname = GHC.moduleNameString $ GHC.moduleName m packageTrusted dflags md - | thisPackage dflags == moduleUnitId md = True - | otherwise = unitIsTrusted $ getPackageDetails dflags (moduleUnitId md) + | thisPackage dflags == moduleUnit md = True + | otherwise = unitIsTrusted $ unsafeGetUnitInfo dflags (moduleUnit md) tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty) | otherwise = S.partition part deps @@ -4185,7 +4185,7 @@ lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module lookupModuleName mName = GHC.lookupModule mName Nothing isHomeModule :: Module -> Bool -isHomeModule m = GHC.moduleUnitId m == mainUnitId +isHomeModule m = GHC.moduleUnit m == mainUnitId -- TODO: won't work if home dir is encoded. -- (changeDirectory may not work either in that case.) @@ -4209,7 +4209,7 @@ wantInterpretedModuleName modname = do modl <- lookupModuleName modname let str = moduleNameString modname dflags <- getDynFlags - when (GHC.moduleUnitId modl /= thisPackage dflags) $ + when (GHC.moduleUnit modl /= thisPackage dflags) $ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) is_interpreted <- GHC.moduleIsInterpreted modl when (not is_interpreted) $ diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 22eb664856..9751aceb8b 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -190,7 +190,7 @@ resolveNameFromModule infos name = do modL <- maybe (throwE $ "No module for" <+> ppr name) return $ nameModule_maybe name - info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <> + info <- maybe (throwE (ppr (moduleUnit modL) <> ":" <> ppr modL)) return $ M.lookup (moduleName modL) infos diff --git a/testsuite/tests/parser/should_run/CountParserDeps.hs b/testsuite/tests/parser/should_run/CountParserDeps.hs index c0b1445dc6..ced0cde750 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.hs +++ b/testsuite/tests/parser/should_run/CountParserDeps.hs @@ -56,7 +56,7 @@ parserDeps libdir = loop _ modules [] = return modules mkModule :: ModuleName -> Module - mkModule = Module (stringToUnitId "ghc") + mkModule = Module (stringToUnit "ghc") modDeps :: ModIface -> [ModuleName] modDeps mi = map fst $ dep_mods (mi_deps mi) diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index 932d98b5c8..4c34a065ca 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -143,7 +143,7 @@ compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do dwarfFileIds = emptyUFM dbgMap = debugToMap [] thisMod = mkModule - (stringToUnitId . show . uniqFromSupply $ usc) + (stringToUnit . show . uniqFromSupply $ usc) (mkModuleName . show . uniqFromSupply $ usd) thisModLoc = ModLocation Nothing (cmmFile ++ ".hi") (cmmFile ++ ".o") (cmmFile ++ ".hie") |