diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-05-12 11:40:03 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-06-13 02:13:02 -0400 |
commit | e7272d53e67e72580caceae40e766c4bfeb1c398 (patch) | |
tree | 5e0d06cf3fc31e737ea385b53efe22e5916e847a /compiler/GHC | |
parent | f6be6e432e53108075905c1fc7785d8b1f18a33f (diff) | |
download | haskell-e7272d53e67e72580caceae40e766c4bfeb1c398.tar.gz |
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
Diffstat (limited to 'compiler/GHC')
28 files changed, 152 insertions, 129 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 36aba77356..a3d1fa5d5b 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -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 {- ************************************************************************ diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs index 3cd55b566d..4dd1b43e83 100644 --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -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 diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs index 1fab779619..03c03fbf2b 100644 --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -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 diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 8d85c5aed0..a0f8c6340d 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -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 diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index eb1ccae3c6..bb502f8cbe 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -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 [] [] [] diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index cc408ca46f..44e34aedbf 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -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 diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 2c04fb8b37..9dd5aeba85 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -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 diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index db9b331d34..e9ac354090 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -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" diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs index 09ef8e2d25..c3332a663c 100644 --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -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 diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index e5381e188f..5d9abc254a 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -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) diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index bbc44a4653..5465ebefd9 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -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 diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 694874a179..9f4c30096e 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -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 } diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index 1b5591793b..3ddd4b1b26 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -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 diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 81b95fba67..816768cc09 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -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 diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index 97ab4ba89a..c68248744f 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -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. diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 542af41557..6778d5aa3f 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -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 diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index 22cd871fad..e45fce9bcc 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs index 49f6a21b9c..e0b20021b3 100644 --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -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)) diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index b0f9fddad6..e70f50ee84 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 3815c2b698..6367f5e839 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -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 diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs index 036220b7c1..04bfea46ce 100644 --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -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 diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs index ef04468ebd..789a3ed661 100644 --- a/compiler/GHC/SysTools/ExtraObj.hs +++ b/compiler/GHC/SysTools/ExtraObj.hs @@ -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 diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 41bc8cd269..d38b7adcbd 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -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 diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 66733b0618..5643ec05fb 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -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 diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 5030c61fd3..ca85a087b6 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -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, diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs index 917c55bca6..d348f7e9e2 100644 --- a/compiler/GHC/Unit/Info.hs +++ b/compiler/GHC/Unit/Info.hs @@ -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 diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index 64c4fdaee2..7f81605435 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -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 wired_in_pkgs = catMaybes mb_wired_in_pkgs pkgstate = pkgState dflags wiredInMap :: Map WiredUnitId WiredUnitId wiredInMap = Map.fromList - [ (key, Definite (stringToUnitId wiredInUnitId)) + [ (key, Definite wiredInUnitId) | (wiredInUnitId, pkg) <- wired_in_pkgs , Just key <- pure $ definiteUnitInfoId pkg ] @@ -1542,7 +1543,8 @@ mkPackageState dflags dbs preload0 = do -- add base & rts to the preload packages basicLinkedPackages | gopt Opt_AutoLinkPackages dflags - = filter (flip elemUDFM (unUnitInfoMap pkg_db)) + = fmap (RealUnit . Definite) $ + filter (flip elemUDFM (unUnitInfoMap pkg_db)) [baseUnitId, rtsUnitId] | otherwise = [] -- but in any case remove the current package from the set of @@ -1991,7 +1993,7 @@ getPreloadPackagesAnd dflags pkgids0 = pairs = zip pkgids (repeat Nothing) in do all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) - return (map (getInstalledPackageDetails state) all_pkgs) + return (map (unsafeLookupUnitId state) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). @@ -2023,7 +2025,7 @@ add_package :: DynFlags add_package dflags pkg_db ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = - case lookupInstalledPackage' pkg_db p of + case lookupUnitId' pkg_db p of Nothing -> Failed (missingPackageMsg p <> missingDependencyMsg mb_parent) Just pkg -> do @@ -2062,7 +2064,7 @@ missingDependencyMsg (Just parent) mkIndefUnitId :: PackageState -> FastString -> IndefUnitId mkIndefUnitId pkgstate raw = let uid = UnitId raw - in case lookupInstalledPackage pkgstate uid of + in case lookupUnitId pkgstate uid of Nothing -> Indefinite uid Nothing -- we didn't find the unit at all Just c -> Indefinite uid $ Just $ mkUnitPprInfo c @@ -2073,7 +2075,7 @@ updateIndefUnitId pkgstate uid = mkIndefUnitId pkgstate (unitIdFS (indefUnit uid displayUnitId :: PackageState -> UnitId -> Maybe String displayUnitId pkgstate uid = - fmap unitPackageIdString (lookupInstalledPackage pkgstate uid) + fmap unitPackageIdString (lookupUnitId pkgstate uid) -- ----------------------------------------------------------------------------- -- Displaying packages diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index 6e04526607..63816d5b09 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -62,6 +62,16 @@ module GHC.Unit.Types , mainUnitId , thisGhcUnitId , interactiveUnitId + + , primUnit + , integerUnit + , baseUnit + , rtsUnit + , thUnit + , mainUnit + , thisGhcUnit + , interactiveUnit + , isInteractiveModule , wiredInUnitIds @@ -162,7 +172,7 @@ pprModule mod@(Module p n) = getPprStyle doc where doc sty | codeStyle sty = - (if p == mainUnitId + (if p == mainUnit then empty -- never qualify the main package in code else ztext (zEncodeFS (unitFS p)) <> char '_') <> pprModuleName n @@ -612,27 +622,38 @@ For `integer-gmp`/`integer-simple` we also change the base name to See Note [The integer library] in "GHC.Builtin.Names". -} -integerUnitId, primUnitId, - baseUnitId, rtsUnitId, - 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 = fsToUnit (fsLit "base") -rtsUnitId = fsToUnit (fsLit "rts") -thUnitId = fsToUnit (fsLit "template-haskell") -thisGhcUnitId = fsToUnit (fsLit "ghc") -interactiveUnitId = fsToUnit (fsLit "interactive") +integerUnitId, primUnitId, baseUnitId, rtsUnitId, + thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId + +integerUnit, primUnit, baseUnit, rtsUnit, + thUnit, mainUnit, thisGhcUnit, interactiveUnit :: Unit + +primUnitId = UnitId (fsLit "ghc-prim") +integerUnitId = UnitId (fsLit "integer-wired-in") +baseUnitId = UnitId (fsLit "base") +rtsUnitId = UnitId (fsLit "rts") +thisGhcUnitId = UnitId (fsLit "ghc") +interactiveUnitId = UnitId (fsLit "interactive") +thUnitId = UnitId (fsLit "template-haskell") + +thUnit = RealUnit (Definite thUnitId) +primUnit = RealUnit (Definite primUnitId) +integerUnit = RealUnit (Definite integerUnitId) +baseUnit = RealUnit (Definite baseUnitId) +rtsUnit = RealUnit (Definite rtsUnitId) +thisGhcUnit = RealUnit (Definite thisGhcUnitId) +interactiveUnit = RealUnit (Definite interactiveUnitId) -- | 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 = fsToUnit (fsLit "main") +mainUnitId = UnitId (fsLit "main") +mainUnit = RealUnit (Definite mainUnitId) isInteractiveModule :: Module -> Bool -isInteractiveModule mod = moduleUnit mod == interactiveUnitId +isInteractiveModule mod = moduleUnit mod == interactiveUnit -wiredInUnitIds :: [Unit] +wiredInUnitIds :: [UnitId] wiredInUnitIds = [ primUnitId , integerUnitId |