Commit e7272d53 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Enhance UnitId use

* use UnitId instead of String to identify wired-in units
* use UnitId instead of Unit in the backend (Unit are only use by
  Backpack to produce type-checked interfaces, not real code)
* rename lookup functions for consistency
* documentation
parent f6be6e43
......@@ -614,7 +614,7 @@ rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
mkInteractiveModule :: Int -> Module
-- (mkInteractiveMoudule 9) makes module 'interactive:M9'
mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n))
mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n))
pRELUDE_NAME, mAIN_NAME :: ModuleName
pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude")
......@@ -625,28 +625,28 @@ dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel")
dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim")
mkPrimModule :: FastString -> Module
mkPrimModule m = mkModule primUnitId (mkModuleNameFS m)
mkPrimModule m = mkModule primUnit (mkModuleNameFS m)
mkIntegerModule :: FastString -> Module
mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m)
mkIntegerModule m = mkModule integerUnit (mkModuleNameFS m)
mkBaseModule :: FastString -> Module
mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m)
mkBaseModule m = mkBaseModule_ (mkModuleNameFS m)
mkBaseModule_ :: ModuleName -> Module
mkBaseModule_ m = mkModule baseUnitId m
mkBaseModule_ m = mkModule baseUnit m
mkThisGhcModule :: FastString -> Module
mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m)
mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m)
mkThisGhcModule_ :: ModuleName -> Module
mkThisGhcModule_ m = mkModule thisGhcUnitId m
mkThisGhcModule_ m = mkModule thisGhcUnit m
mkMainModule :: FastString -> Module
mkMainModule m = mkModule mainUnitId (mkModuleNameFS m)
mkMainModule m = mkModule mainUnit (mkModuleNameFS m)
mkMainModule_ :: ModuleName -> Module
mkMainModule_ m = mkModule mainUnitId m
mkMainModule_ m = mkModule mainUnit m
{-
************************************************************************
......
......@@ -170,7 +170,7 @@ thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
mkTHModule :: FastString -> Module
mkTHModule m = mkModule thUnitId (mkModuleNameFS m)
mkTHModule m = mkModule thUnit (mkModuleNameFS m)
libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name
libFun = mk_known_key_name varName thLib
......
......@@ -169,7 +169,7 @@ nameToCLabel n suffix = mkFastString label
occPart = encodeZ (occNameFS (nameOccName n))
label = concat
[ if pkgKey == mainUnitId then "" else packagePart ++ "_"
[ if pkgKey == mainUnit then "" else packagePart ++ "_"
, modulePart
, '_':occPart
, '_':suffix
......
......@@ -186,7 +186,7 @@ data CLabel
-- | A label from a .cmm file that is not associated with a .hs level Id.
| CmmLabel
Unit -- what package the label belongs to.
UnitId -- what package the label belongs to.
FastString -- identifier giving the prefix of the label
CmmLabelInfo -- encodes the suffix of the label
......@@ -552,7 +552,7 @@ mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
-----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel
:: Unit -> FastString -> CLabel
:: UnitId -> FastString -> CLabel
mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo
mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry
......@@ -583,7 +583,7 @@ mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off)
-- A call to some primitive hand written Cmm code
mkPrimCallLabel :: PrimCall -> CLabel
mkPrimCallLabel (PrimCall str pkg)
= CmmLabel pkg str CmmPrimCall
= CmmLabel (toUnitId pkg) str CmmPrimCall
-- Constructing ForeignLabels
......@@ -1032,7 +1032,7 @@ labelDynamic config this_mod lbl =
case lbl of
-- is the RTS in a DLL or not?
RtsLabel _ ->
externalDynamicRefs && (this_pkg /= rtsUnitId)
externalDynamicRefs && (this_pkg /= rtsUnit)
IdLabel n _ _ ->
externalDynamicRefs && isDynLinkName platform this_mod n
......@@ -1040,7 +1040,7 @@ labelDynamic config this_mod lbl =
-- When compiling in the "dyn" way, each package is to be linked into
-- its own shared library.
CmmLabel pkg _ _
| os == OSMinGW32 -> externalDynamicRefs && (this_pkg /= pkg)
| os == OSMinGW32 -> externalDynamicRefs && (toUnitId this_pkg /= pkg)
| otherwise -> externalDynamicRefs
LocalBlockLabel _ -> False
......
......@@ -377,7 +377,7 @@ cmmtop :: { CmmParse () }
| cmmdata { $1 }
| decl { $1 }
| 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
{% liftP . withHomeUnit $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do lits <- sequence $6;
staticClosure pkg $3 $5 (map getLit lits) }
......@@ -398,7 +398,7 @@ cmmdata :: { CmmParse () }
data_label :: { CmmParse CLabel }
: NAME ':'
{% liftP . withHomeUnit $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
return (mkCmmDataLabel pkg $1) }
statics :: { [CmmParse [CmmStatic]] }
......@@ -455,14 +455,14 @@ maybe_body :: { CmmParse () }
info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
: NAME
{% liftP . withHomeUnit $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do newFunctionName $1 pkg
return (mkCmmCodeLabel pkg $1, Nothing, []) }
| 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{% liftP . withHomeUnit $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
rep = mkRTSRep (fromIntegral $9) $
......@@ -478,7 +478,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
{% liftP . withHomeUnit $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
ty = Fun 0 (ArgSpec (fromIntegral $15))
......@@ -496,7 +496,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
{% liftP . withHomeUnit $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $13 $15
ty = Constr (fromIntegral $9) -- Tag
......@@ -515,7 +515,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{% liftP . withHomeUnit $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $9 $11
ty = ThunkSelector (fromIntegral $5)
......@@ -529,7 +529,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs)
{% liftP . withHomeUnit $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do let prof = NoProfilingInfo
rep = mkRTSRep (fromIntegral $5) $ mkStackRep []
return (mkCmmRetLabel pkg $3,
......@@ -540,7 +540,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- closure type, live regs
{% liftP . withHomeUnit $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let platform = targetPlatform dflags
live <- sequence $7
......@@ -583,9 +583,9 @@ importName
| 'CLOSURE' NAME
{ ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
-- A label imported with an explicit packageId.
-- A label imported with an explicit UnitId.
| STRING NAME
{ ($2, mkCmmCodeLabel (fsToUnit (mkFastString $1)) $2) }
{ ($2, mkCmmCodeLabel (UnitId (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 :: Unit -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
= do dflags <- getDynFlags
let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
......
......@@ -1556,9 +1556,9 @@ lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of
-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
guardIntegerUse :: DynFlags -> IO a -> IO a
guardIntegerUse dflags act
| homeUnit dflags == primUnitId
| homeUnitId dflags == primUnitId
= return $ panic "Can't use Integer in ghc-prim"
| homeUnit dflags == integerUnitId
| homeUnitId dflags == integerUnitId
= return $ panic "Can't use Integer in integer-*"
| otherwise = act
......@@ -1568,11 +1568,11 @@ guardIntegerUse dflags act
-- literals in `base`. If we do, we get interface loading error for GHC.Natural.
guardNaturalUse :: DynFlags -> IO a -> IO a
guardNaturalUse dflags act
| homeUnit dflags == primUnitId
| homeUnitId dflags == primUnitId
= return $ panic "Can't use Natural in ghc-prim"
| homeUnit dflags == integerUnitId
| homeUnitId dflags == integerUnitId
= return $ panic "Can't use Natural in integer-*"
| homeUnit dflags == baseUnitId
| homeUnitId dflags == baseUnitId
= return $ panic "Can't use Natural in base"
| otherwise = act
......
......@@ -366,7 +366,7 @@ buildUnit session cid insts lunit = do
compileExe :: LHsUnit HsComponentId -> BkpM ()
compileExe lunit = do
msgUnitId mainUnitId
msgUnitId mainUnit
let deps_w_rns = hsunitDeps False (unLoc lunit)
deps = map fst deps_w_rns
-- no renaming necessary
......
......@@ -131,7 +131,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 = unsafeLookupUnit (pkgState dflags) rtsUnitId
let rts = unsafeLookupUnitId (pkgState dflags) rtsUnitId
let cc_injects = unlines (map mk_include (unitIncludes rts))
mk_include h_file =
......@@ -223,7 +223,7 @@ outputForeignStubs dflags mod location stubs
-- we need the #includes from the rts package for the stub files
let rts_includes =
let rts_pkg = unsafeLookupUnit (pkgState dflags) rtsUnitId in
let rts_pkg = unsafeLookupUnitId (pkgState dflags) rtsUnitId in
concatMap mk_include (unitIncludes rts_pkg)
mk_include i = "#include \"" ++ i ++ "\"\n"
......
......@@ -345,7 +345,7 @@ findPackageModule hsc_env mod = do
pkg_id = moduleUnit mod
pkgstate = pkgState dflags
--
case lookupInstalledPackage pkgstate pkg_id of
case lookupUnitId pkgstate pkg_id of
Nothing -> return (InstalledNoPackage pkg_id)
Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
......
......@@ -1218,7 +1218,7 @@ checkPkgTrust pkgs = do
let errors = S.foldr go [] pkgs
state = pkgState dflags
go pkg acc
| unitIsTrusted $ getInstalledPackageDetails state pkg
| unitIsTrusted $ unsafeLookupUnitId state pkg
= acc
| otherwise
= (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state)
......
......@@ -515,7 +515,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- not extra_libraries or -l things from the command line.
let pkgstate = pkgState dflags
let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib)
| Just c <- map (lookupInstalledPackage pkgstate) pkg_deps,
| Just c <- map (lookupUnitId pkgstate) pkg_deps,
lib <- packageHsLibs dflags c ]
pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
......@@ -1312,7 +1312,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
-- way we do the import depends on whether we're currently compiling
-- the base package or not.
++ (if platformOS platform == OSMinGW32 &&
homeUnit dflags == baseUnitId
homeUnitId dflags == baseUnitId
then [ "-DCOMPILING_BASE_PACKAGE" ]
else [])
......@@ -2223,7 +2223,7 @@ getGhcVersionPathName dflags = do
candidates <- case ghcVersionFile dflags of
Just path -> return [path]
Nothing -> (map (</> "ghcversion.h")) <$>
(getPackageIncludePath dflags [toUnitId rtsUnitId])
(getPackageIncludePath dflags [rtsUnitId])
found <- filterM doesFileExist candidates
case found of
......
......@@ -1329,7 +1329,7 @@ defaultDynFlags mySettings llvmConfig =
reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH,
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
homeUnitId = toUnitId mainUnitId,
homeUnitId = mainUnitId,
homeUnitInstanceOfId = Nothing,
homeUnitInstantiations = [],
......@@ -1980,7 +1980,7 @@ homeUnit dflags =
-- detect fully indefinite units: all their instantiations are hole
-- modules and the home unit id is the same as the instantiating unit
-- id (see Note [About units] in GHC.Unit)
| all (isHoleModule . snd) is && u == homeUnitId dflags
| all (isHoleModule . snd) is && indefUnit u == homeUnitId dflags
-> mkVirtUnit (updateIndefUnitId (pkgState dflags) u) is
-- otherwise it must be that we compile a fully definite units
-- TODO: error when the unit is partially instantiated??
......@@ -4637,10 +4637,10 @@ setMainIs arg
| not (null main_fn) && isLower (head main_fn)
-- The arg looked like "Foo.Bar.baz"
= upd $ \d -> d { mainFunIs = Just main_fn,
mainModIs = mkModule mainUnitId (mkModuleName main_mod) }
mainModIs = mkModule mainUnit (mkModuleName main_mod) }
| isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar"
= upd $ \d -> d { mainModIs = mkModule mainUnitId (mkModuleName arg) }
= upd $ \d -> d { mainModIs = mkModule mainUnit (mkModuleName arg) }
| otherwise -- The arg looked like "baz"
= upd $ \d -> d { mainFunIs = Just arg }
......
......@@ -1852,7 +1852,7 @@ shadowed_by ids = shadowed
setInteractivePackage :: HscEnv -> HscEnv
setInteractivePackage hsc_env
= hsc_env { hsc_dflags = (hsc_dflags hsc_env)
{ homeUnitId = toUnitId interactiveUnitId } }
{ homeUnitId = interactiveUnitId } }
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName ic n = ic{ic_int_print = n}
......@@ -2030,7 +2030,7 @@ mkQualModule dflags mod
-- with a unit id if the package ID would be ambiguous.
mkQualPackage :: PackageState -> QueryQualifyPackage
mkQualPackage pkgs uid
| uid == mainUnitId || uid == interactiveUnitId
| uid == mainUnit || uid == interactiveUnit
-- Skip the lookup if it's main, since it won't be in the package
-- database!
= False
......
......@@ -180,7 +180,7 @@ writeMixEntries dflags mod count entries filename
mod_name = moduleNameString (moduleName mod)
hpc_mod_dir
| moduleUnit mod == mainUnitId = hpc_dir
| moduleUnit mod == mainUnit = hpc_dir
| otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod)
tabStop = 8 -- <tab> counts as a normal char in GHC's
......@@ -1337,7 +1337,7 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo)
package_name = hcat (map (text.charToC) $ BS.unpack $
bytesFS (unitFS (moduleUnit this_mod)))
full_name_str
| moduleUnit this_mod == mainUnitId
| moduleUnit this_mod == mainUnit
= module_name
| otherwise
= package_name <> char '/' <> module_name
......@@ -86,7 +86,7 @@ mkDependencies iuid pluginModules
raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs
pkgs | th_used = Set.insert (toUnitId thUnitId) raw_pkgs
pkgs | th_used = Set.insert thUnitId raw_pkgs
| otherwise = raw_pkgs
-- Set the packages required to be Safe according to Safe Haskell.
......
......@@ -55,7 +55,7 @@ module GHC.Parser.Lexer (
appendError,
allocateComments,
MonadP(..),
getRealSrcLoc, getPState, withHomeUnit,
getRealSrcLoc, getPState, withHomeUnitId,
failMsgP, failLocMsgP, srcParseFail,
getErrorMessages, getMessages,
popContext, pushModuleContext, setLastToken, setSrcLoc,
......@@ -2088,7 +2088,7 @@ warnopt f options = f `EnumSet.member` pWarningFlags options
-- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this.
data ParserFlags = ParserFlags {
pWarningFlags :: EnumSet WarningFlag
, pHomeUnit :: Unit -- ^ unit currently being compiled
, pHomeUnitId :: UnitId -- ^ unit currently being compiled
, pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions
}
......@@ -2183,8 +2183,8 @@ failLocMsgP loc1 loc2 str =
getPState :: P PState
getPState = P $ \s -> POk s s
withHomeUnit :: (Unit -> a) -> P a
withHomeUnit f = P $ \s@(PState{options = o}) -> POk s (f (pHomeUnit o))
withHomeUnitId :: (UnitId -> a) -> P a
withHomeUnitId f = P $ \s@(PState{options = o}) -> POk s (f (pHomeUnitId o))
getExts :: P ExtsBitmap
getExts = P $ \s -> POk s (pExtsBitmap . options $ s)
......@@ -2500,7 +2500,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
mkParserFlags'
:: EnumSet WarningFlag -- ^ warnings flags enabled
-> EnumSet LangExt.Extension -- ^ permitted language extensions enabled
-> Unit -- ^ key of package currently being compiled
-> UnitId -- ^ id of the unit currently being compiled
-> Bool -- ^ are safe imports on?
-> Bool -- ^ keeping Haddock comment tokens
-> Bool -- ^ keep regular comment tokens
......@@ -2512,11 +2512,11 @@ mkParserFlags'
-> ParserFlags
-- ^ Given exactly the information needed, set up the 'ParserFlags'
mkParserFlags' warningFlags extensionFlags homeUnit
mkParserFlags' warningFlags extensionFlags homeUnitId
safeImports isHaddock rawTokStream usePosPrags =
ParserFlags {
pWarningFlags = warningFlags
, pHomeUnit = homeUnit
, pHomeUnitId = homeUnitId
, pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits
}
where
......@@ -2578,7 +2578,7 @@ mkParserFlags =
mkParserFlags'
<$> DynFlags.warningFlags
<*> DynFlags.extensionFlags
<*> DynFlags.homeUnit
<*> DynFlags.homeUnitId
<*> safeImportsOn
<*> gopt Opt_Haddock
<*> gopt Opt_KeepRawTokenStream
......
......@@ -143,7 +143,7 @@ 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 toUnitId [rtsUnitId]
where init_pkgs = [rtsUnitId]
extendLoadedPkgs :: DynLinker -> [UnitId] -> IO ()
extendLoadedPkgs dl pkgs =
......@@ -1261,7 +1261,7 @@ linkPackages' hsc_env new_pks pls = do
| new_pkg `elem` pkgs -- Already linked
= return pkgs
| Just pkg_cfg <- lookupInstalledPackage pkgstate new_pkg
| Just pkg_cfg <- lookupUnitId pkgstate new_pkg
= do { -- Link dependents first
pkgs' <- link pkgs (unitDepends pkg_cfg)
-- Now link the package itself
......
......@@ -61,7 +61,7 @@ data Named
= VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
-- eg, RtsLabel, ForeignLabel, CmmLabel etc.
| FunN Unit -- ^ A function name from this package
| FunN UnitId -- ^ A function name from this unit
| LabelN BlockId -- ^ A blockid of some code or data.
-- | An environment of named things.
......@@ -165,7 +165,7 @@ newLabel name = do
-- | Add add a local function to the environment.
newFunctionName
:: FastString -- ^ name of the function
-> Unit -- ^ package of the current module
-> UnitId -- ^ package of the current module
-> ExtCode
newFunctionName name pkg = addDecl name (FunN pkg)
......@@ -204,7 +204,7 @@ lookupName name = do
return $
case lookupUFM env name of
Just (VarN e) -> e
Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name))
Just (FunN uid) -> CmmLit (CmmLabel (mkCmmCodeLabel uid name))
_other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))
......
......@@ -42,7 +42,7 @@ import GHC.Cmm.BlockId
import GHC.Cmm.Graph
import GHC.Stg.Syntax
import GHC.Cmm
import GHC.Unit ( rtsUnitId )
import GHC.Unit ( rtsUnit )
import GHC.Core.Type ( Type, tyConAppTyCon )
import GHC.Core.TyCon
import GHC.Cmm.CLabel
......@@ -3043,7 +3043,7 @@ emitCopyUpdRemSetPush platform hdr_size dst dst_off n =
emit graph
where
lbl = mkLblExpr $ mkPrimCallLabel
$ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId
$ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit
args =
[ mkIntExpr platform hdr_size
, dst
......
......@@ -180,10 +180,10 @@ tagToClosure platform tycon tag
--
-------------------------------------------------------------------------
emitRtsCall :: Unit -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
emitRtsCallWithResult :: LocalReg -> ForeignHint -> Unit -> FastString
emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult res hint pkg fun args safe
= emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
......
......@@ -276,7 +276,7 @@ linkDynLib dflags0 o_files dep_packages
OSMinGW32 ->
pkgs
_ ->
filter ((/= rtsUnitId) . mkUnit) pkgs
filter ((/= rtsUnitId) . unitId) 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
......
......@@ -57,7 +57,7 @@ mkExtraObj dflags extn xs
-- set of include directories and PIC flags.
cOpts = map Option (picCCOpts dflags)
++ map (FileOption "-I")
(unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnitId)
(unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit)
-- 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
......
......@@ -2174,7 +2174,7 @@ sameOccExtra ty1 ty2
| otherwise -- Imported things have an UnhelpfulSrcSpan
= hang (quotes (ppr nm))
2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))
, ppUnless (same_pkg || pkg == mainUnitId) $
, ppUnless (same_pkg || pkg == mainUnit) $
nest 4 $ text "in package" <+> quotes (ppr pkg) ])
where
pkg = moduleUnit mod
......
......@@ -568,7 +568,7 @@ mergeSignatures
let insts = instUnitInsts iuid
isFromSignaturePackage =
let inst_uid = instUnitInstanceOf iuid
pkg = getInstalledPackageDetails pkgstate (indefUnit inst_uid)
pkg = unsafeLookupUnitId 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
......
......@@ -265,7 +265,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 moduleUnit mod == primUnitId
tcg_default = if moduleUnit mod == primUnit
then Just [] -- See Note [Default types]
else Nothing,
tcg_type_env = emptyNameEnv,
......
......@@ -167,9 +167,9 @@ expandedUnitInfoId p =
definiteUnitInfoId :: UnitInfo -> Maybe DefUnitId
definiteUnitInfoId p =
case mkUnit p of
RealUnit def_uid -> Just def_uid
_ -> Nothing
if unitIsIndefinite p
then Nothing
else Just (Definite (unitId p))
-- | Create a UnitPprInfo from a UnitInfo
mkUnitPprInfo :: GenUnitInfo u -> UnitPprInfo
......
......@@ -21,12 +21,14 @@ module GHC.Unit.State (
-- * Querying the package config
lookupUnit,
lookupUnit',
lookupInstalledPackage,
unsafeLookupUnit,
lookupUnitId,
lookupUnitId',
unsafeLookupUnitId,
lookupPackageName,
improveUnit,
searchPackageId,
unsafeLookupUnit,
getInstalledPackageDetails,
displayUnitId,
listVisibleModuleNames,
lookupModuleInAllPackages,
......@@ -393,7 +395,7 @@ type InstalledPackageIndex = Map UnitId UnitInfo
emptyUnitInfoMap :: UnitInfoMap
emptyUnitInfoMap = UnitInfoMap emptyUDFM emptyUniqSet
-- | Find the unit we know about with the given unit id, if any
-- | Find the unit we know about with the given unit, if any
lookupUnit :: PackageState -> Unit -> Maybe UnitInfo
lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs)
......@@ -409,6 +411,28 @@ lookupUnit' True m@(UnitInfoMap pkg_map _) uid = case uid of
VirtUnit i -> fmap (renamePackage m (instUnitInsts i))
(lookupUDFM pkg_map (instUnitInstanceOf i))
-- | Find the unit we know about with the given unit id, if any
lookupUnitId :: PackageState -> UnitId -> Maybe UnitInfo
lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid
-- | Find the unit we know about with the given unit id, if any
lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' (UnitInfoMap db _) uid = lookupUDFM db uid
-- | Looks up the given unit in the package state, panicing if it is not found
unsafeLookupUnit :: HasDebugCallStack => PackageState -> Unit -> UnitInfo
unsafeLookupUnit state u = case lookupUnit state u of
Just info -> info
Nothing -> pprPanic "unsafeLookupUnit" (ppr u)
-- | Looks up the given unit id in the package state, panicing if it is not found
unsafeLookupUnitId :: HasDebugCallStack => PackageState -> UnitId -> UnitInfo
unsafeLookupUnitId state uid = case lookupUnitId state uid of
Just info -> info
Nothing -> pprPanic "unsafeLookupUnitId" (ppr uid)
-- | 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 IndefUnitId
......@@ -429,26 +453,6 @@ extendUnitInfoMap (UnitInfoMap pkg_map closure) new_pkgs
where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedUnitInfoId p) p)
(unitId p) p
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
unsafeLookupUnit :: HasDebugCallStack => PackageState -> Unit -> UnitInfo
unsafeLookupUnit pkgs pid =
case lookupUnit pkgs pid of
Just info -> info
Nothing -> pprPanic "unsafeLookupUnit" (ppr pid)
lookupInstalledPackage :: PackageState -> UnitId -> Maybe UnitInfo
lookupInstalledPackage pkgstate uid = lookupInstalledPackage' (unitInfoMap pkgstate) uid
lookupInstalledPackage' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupInstalledPackage' (UnitInfoMap db _) uid = lookupUDFM db uid
getInstalledPackageDetails :: HasDebugCallStack => PackageState -> UnitId -> UnitInfo
getInstalledPackageDetails pkgstate uid =
case lookupInstalledPackage pkgstate uid of
Just config -> config
Nothing -> pprPanic "getInstalledPackageDetails" (ppr uid)
-- | Get a list of entries from the package database. NB: be careful with
-- this function, although all packages in this map are "visible", this
-- does not imply that the exposed-modules of the package are available
......@@ -945,12 +949,9 @@ pprTrustFlag flag = case flag of
--
-- See Note [Wired-in units] in GHC.Unit.Module
type WiredInUnitId = String
type WiredInUnitId = UnitId
type WiredPackagesMap = Map WiredUnitId WiredUnitId
wired_in_unitids :: [WiredInUnitId]
wired_in_unitids = map unitString wiredInUnitIds
findWiredInPackages
:: DynFlags
-> PackagePrecedenceIndex
......@@ -968,9 +969,9 @@ 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 == unitString integerUnitId
| pid == integerUnitId
= unitPackageNameString pc `elem` ["integer-gmp", "integer-simple"]
pc `matches` pid = unitPackageNameString pc == pid
pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid)
-- find which package corresponds to each wired-in package
-- delete any other packages with the same name
......@@ -1005,7 +1006,7 @@ findWiredInPackages dflags prec_map pkgs vis_map = do
notfound = do
debugTraceMsg dflags 2 $
text "wired-in package "
<> text wired_pkg
<> ftext (unitIdFS wired_pkg)
<> text " not found."
return Nothing
pick :: UnitInfo
......@@ -1013,20 +1014,20 @@ findWiredInPackages dflags prec_map pkgs vis_map = do
pick pkg = do
debugTraceMsg dflags 2 $
text "wired-in package "
<> text wired_pkg
<> ftext (unitIdFS wired_pkg)
<> text " mapped to "
<> ppr (unitId pkg)
return (Just (wired_pkg, pkg))
mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_unitids
mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wiredInUnitIds
let