summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/DynFlags.hs72
-rw-r--r--compiler/main/Finder.hs2
-rw-r--r--compiler/main/GhcMake.hs4
-rw-r--r--compiler/main/HscTypes.hs7
-rw-r--r--compiler/main/PackageConfig.hs5
-rw-r--r--compiler/main/Packages.hs42
-rw-r--r--compiler/main/Packages.hs-boot3
7 files changed, 80 insertions, 55 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 69fb8b814d..cb2866442e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -54,11 +54,12 @@ module DynFlags (
dynFlagDependencies,
tablesNextToCode, mkTablesNextToCode,
makeDynFlagsConsistent,
- thisUnitIdComponentId,
Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
wayGeneralFlags, wayUnsetGeneralFlags,
+ thisPackage, thisComponentId, thisUnitIdInsts,
+
-- ** Safe Haskell
SafeHaskellMode(..),
safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
@@ -688,9 +689,9 @@ data DynFlags = DynFlags {
solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver
-- Typically only 1 is needed
- thisPackage :: UnitId, -- ^ unit id of package currently being compiled.
- -- Not properly initialized until initPackages
- thisUnitIdInsts :: [(ModuleName, Module)],
+ thisInstalledUnitId :: InstalledUnitId,
+ thisComponentId_ :: Maybe ComponentId,
+ thisUnitIdInsts_ :: Maybe [(ModuleName, Module)],
-- ways
ways :: [Way], -- ^ Way flags from the command line
@@ -1487,8 +1488,9 @@ defaultDynFlags mySettings =
reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH,
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
- thisPackage = mainUnitId,
- thisUnitIdInsts = [],
+ thisInstalledUnitId = toInstalledUnitId mainUnitId,
+ thisUnitIdInsts_ = Nothing,
+ thisComponentId_ = Nothing,
objectDir = Nothing,
dylibInstallName = Nothing,
@@ -2003,6 +2005,34 @@ setOutputFile f d = d { outputFile = f}
setDynOutputFile f d = d { dynOutputFile = f}
setOutputHi f d = d { outputHi = f}
+thisComponentId :: DynFlags -> ComponentId
+thisComponentId dflags =
+ case thisComponentId_ dflags of
+ Just cid -> cid
+ Nothing ->
+ case thisUnitIdInsts_ dflags of
+ Just _ ->
+ throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
+ Nothing -> ComponentId (unitIdFS (thisPackage dflags))
+
+thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)]
+thisUnitIdInsts dflags =
+ case thisUnitIdInsts_ dflags of
+ Just insts -> insts
+ Nothing -> []
+
+thisPackage :: DynFlags -> UnitId
+thisPackage dflags =
+ case thisUnitIdInsts_ dflags of
+ Nothing -> default_uid
+ Just insts
+ | all (\(x,y) -> mkHoleModule x == y) insts
+ -> newUnitId (thisComponentId dflags) insts
+ | otherwise
+ -> default_uid
+ where
+ default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags))
+
parseUnitIdInsts :: String -> [(ModuleName, Module)]
parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
[(r, "")] -> r
@@ -2015,17 +2045,12 @@ parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
return (n, m)
setUnitIdInsts :: String -> DynFlags -> DynFlags
-setUnitIdInsts s d = updateWithInsts (parseUnitIdInsts s) d
-
-updateWithInsts :: [(ModuleName, Module)] -> DynFlags -> DynFlags
-updateWithInsts insts d =
- -- Overwrite the instances, the instances are "indefinite"
- d { thisPackage =
- if not (null insts) && all (\(x,y) -> mkHoleModule x == y) insts
- then newUnitId (unitIdComponentId (thisPackage d)) insts
- else thisPackage d
- , thisUnitIdInsts = insts
- }
+setUnitIdInsts s d =
+ d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) }
+
+setComponentId :: String -> DynFlags -> DynFlags
+setComponentId s d =
+ d { thisComponentId_ = Just (ComponentId (fsLit s)) }
addPluginModuleName :: String -> DynFlags -> DynFlags
addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
@@ -2368,6 +2393,7 @@ dynamic_flags_deps = [
-- parallel builds is equal to the
-- result of getNumProcessors
, make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts)
+ , make_ord_flag defFlag "this-component-id" (sepArg setComponentId)
-- RTS options -------------------------------------------------------------
, make_ord_flag defFlag "H" (HasArg (\s -> upd (\d ->
@@ -4357,18 +4383,8 @@ parseUnitIdArg :: ReadP PackageArg
parseUnitIdArg =
fmap UnitIdArg parseUnitId
-
-thisUnitIdComponentId :: DynFlags -> ComponentId
-thisUnitIdComponentId = unitIdComponentId . thisPackage
-
setUnitId :: String -> DynFlags -> DynFlags
-setUnitId p d =
- updateWithInsts (thisUnitIdInsts d) $ d{ thisPackage = uid }
- where
- uid =
- case filter ((=="").snd) (readP_to_S parseUnitId p) of
- [(r, "")] -> r
- _ -> throwGhcException $ CmdLineError ("Can't parse component id: " ++ p)
+setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p }
-- | Given a 'ModuleName' of a signature in the home library, find
-- out how it is instantiated. E.g., the canonical form of
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
index 2bcdd3360c..d1bf1c8073 100644
--- a/compiler/main/Finder.hs
+++ b/compiler/main/Finder.hs
@@ -335,7 +335,7 @@ findPackageModule hsc_env mod = do
-- for the appropriate config.
findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult
findPackageModule_ hsc_env mod pkg_conf =
- ASSERT( installedModuleUnitId mod == installedPackageConfigId pkg_conf )
+ ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )
modLocationCache hsc_env mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 0921a58531..cd9fb15ae4 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1264,7 +1264,9 @@ unitIdsToCheck dflags =
where
goUnitId uid =
case splitUnitIdInsts uid of
- (_, Just insts) -> uid : concatMap (goUnitId . moduleUnitId . snd) insts
+ (_, Just indef) ->
+ let insts = indefUnitIdInsts indef
+ in uid : concatMap (goUnitId . moduleUnitId . snd) insts
_ -> []
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 1320a57e9a..7a585f3bba 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -959,10 +959,10 @@ mi_semantic_module iface = case mi_sig_of iface of
mi_free_holes :: ModIface -> UniqDSet ModuleName
mi_free_holes iface =
case splitModuleInsts (mi_module iface) of
- (_, Just insts)
+ (_, Just indef)
-- A mini-hack: we rely on the fact that 'renameFreeHoles'
-- drops things that aren't holes.
- -> renameFreeHoles (mkUniqDSet cands) insts
+ -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef))
_ -> emptyUniqDSet
where
cands = map fst (dep_mods (mi_deps iface))
@@ -1596,7 +1596,8 @@ extendInteractiveContextWithIds ictxt new_ids
setInteractivePackage :: HscEnv -> HscEnv
-- Set the 'thisPackage' DynFlag to 'interactive'
setInteractivePackage hsc_env
- = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactiveUnitId } }
+ = hsc_env { hsc_dflags = (hsc_dflags hsc_env)
+ { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } }
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName ic n = ic{ic_int_print = n}
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index 6e3e2f1c9b..bff8cc3aa3 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -37,7 +37,6 @@ import FastString
import Outputable
import Module
import Unique
-import UniqDSet
-- -----------------------------------------------------------------------------
-- Our PackageConfig type is the InstalledPackageInfo from ghc-boot,
@@ -138,12 +137,12 @@ installedPackageConfigId = unitId
packageConfigId :: PackageConfig -> UnitId
packageConfigId p =
if indefinite p
- then newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p)
+ then newUnitId (componentId p) (instantiatedWith p)
else DefiniteUnitId (DefUnitId (unitId p))
expandedPackageConfigId :: PackageConfig -> UnitId
expandedPackageConfigId p =
- newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p)
+ newUnitId (componentId p) (instantiatedWith p)
definitePackageConfigId :: PackageConfig -> Maybe DefUnitId
definitePackageConfigId p =
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 566d998899..e0563da10c 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -27,6 +27,7 @@ module Packages (
getPackageDetails,
getInstalledPackageDetails,
componentIdString,
+ displayInstalledUnitId,
listVisibleModuleNames,
lookupModuleInAllPackages,
lookupModuleWithSuggestions,
@@ -268,7 +269,7 @@ data UnitVisibility = UnitVisibility
-- ^ The package name is associated with the 'UnitId'. This is used
-- to implement legacy behavior where @-package foo-0.1@ implicitly
-- hides any packages named @foo@
- , uv_requirements :: Map ModuleName (Set HoleModule)
+ , uv_requirements :: Map ModuleName (Set IndefModule)
-- ^ The signatures which are contributed to the requirements context
-- from this unit ID.
, uv_explicit :: Bool
@@ -351,7 +352,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 [HoleModule]
+ requirementContext :: Map ModuleName [IndefModule]
}
emptyPackageState :: PackageState
@@ -384,8 +385,8 @@ lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid
lookupPackage' True m@(PackageConfigMap pkg_map _) uid =
case splitUnitIdInsts uid of
- (iuid, Just insts) ->
- fmap (renamePackage m insts)
+ (iuid, Just indef) ->
+ fmap (renamePackage m (indefUnitIdInsts indef))
(lookupUDFM pkg_map iuid)
(_, Nothing) -> lookupUDFM pkg_map uid
@@ -689,15 +690,14 @@ applyPackageFlag dflags pkg_db unusable no_hide_others pkgs vm flag =
| otherwise = Map.empty
collectHoles uid = case splitUnitIdInsts uid of
- (_, Just insts) ->
- let cid = unitIdComponentId uid
- local = [ Map.singleton
+ (_, Just indef) ->
+ let local = [ Map.singleton
(moduleName mod)
- (Set.singleton $ (newIndefUnitId cid insts, mod_name))
- | (mod_name, mod) <- insts
+ (Set.singleton $ IndefModule indef mod_name)
+ | (mod_name, mod) <- indefUnitIdInsts indef
, isHoleModule mod ]
recurse = [ collectHoles (moduleUnitId mod)
- | (_, mod) <- insts ]
+ | (_, mod) <- indefUnitIdInsts indef ]
in Map.unionsWith Set.union $ local ++ recurse
-- Other types of unit identities don't have holes
(_, Nothing) -> Map.empty
@@ -764,11 +764,11 @@ findPackages pkg_db arg pkgs unusable
then Just p
else Nothing
finder (UnitIdArg uid) p
- = let (iuid, mb_insts) = splitUnitIdInsts uid
+ = let (iuid, mb_indef) = splitUnitIdInsts uid
in if iuid == installedPackageConfigId p
- then Just (case mb_insts of
+ then Just (case mb_indef of
Nothing -> p
- Just insts -> renamePackage pkg_db insts p)
+ Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p)
else Nothing
selectPackages :: PackageArg -> [PackageConfig]
@@ -968,9 +968,10 @@ findWiredInPackages dflags pkgs vis_map = do
where upd_pkg pkg
| Just def_uid <- definitePackageConfigId pkg
, def_uid `elem` wired_in_ids
- = pkg {
- unitId = let PackageName fs = packageName pkg
- in fsToInstalledUnitId fs
+ = let PackageName fs = packageName pkg
+ in pkg {
+ unitId = fsToInstalledUnitId fs,
+ componentId = ComponentId fs
}
| otherwise
= pkg
@@ -1313,7 +1314,7 @@ mkPackageState dflags dbs preload0 = do
let pkgname_map = foldl add Map.empty pkgs2
where add pn_map p
- = Map.insert (packageName p) (unitIdComponentId (packageConfigId p)) pn_map
+ = Map.insert (packageName p) (componentId p) pn_map
-- The explicitPackages accurately reflects the set of packages we have turned
-- on; as such, it also is the only way one can come up with requirements.
@@ -1713,7 +1714,12 @@ missingDependencyMsg (Just parent)
componentIdString :: DynFlags -> ComponentId -> Maybe String
componentIdString dflags cid =
- fmap sourcePackageIdString (lookupInstalledPackage dflags (newInstalledUnitId cid Nothing))
+ fmap sourcePackageIdString (lookupInstalledPackage dflags
+ (componentIdToInstalledUnitId cid))
+
+displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
+displayInstalledUnitId dflags uid =
+ fmap sourcePackageIdString (lookupInstalledPackage dflags uid)
-- | Will the 'Name' come from a dynamically linked library?
isDllName :: DynFlags -> UnitId {- not used -} -> Module -> Name -> Bool
diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot
index c05d392ce1..0ed59db92b 100644
--- a/compiler/main/Packages.hs-boot
+++ b/compiler/main/Packages.hs-boot
@@ -1,9 +1,10 @@
module Packages where
import {-# SOURCE #-} DynFlags(DynFlags)
-import {-# SOURCE #-} Module(ComponentId, UnitId)
+import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId)
data PackageState
data PackageConfigMap
emptyPackageState :: PackageState
componentIdString :: DynFlags -> ComponentId -> Maybe String
+displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
improveUnitId :: PackageConfigMap -> UnitId -> UnitId
getPackageConfigMap :: DynFlags -> PackageConfigMap
View Lorry Controller Status