diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Unit/State.hs | 77 |
1 files changed, 34 insertions, 43 deletions
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index e568912310..07752cb98d 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -330,6 +330,11 @@ data UnitConfig = UnitConfig -- [About units] in GHC.Unit). This should only be used when we are -- type-checking an indefinite unit (not producing any code). + , unitConfigDBCache :: Maybe [UnitDatabase UnitId] + -- ^ Cache of databases to use, in the order they were specified on the + -- command line (later databases shadow earlier ones). + -- If Nothing, databases will be found using `unitConfigFlagsDB`. + -- command-line flags , unitConfigFlagsDB :: [PackageDBFlag] -- ^ Unit databases flags , unitConfigFlagsExposed :: [PackageFlag] -- ^ Exposed units @@ -338,16 +343,15 @@ data UnitConfig = UnitConfig , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units } -initUnitConfig :: DynFlags -> IO UnitConfig -initUnitConfig dflags = do - +initUnitConfig :: DynFlags -> UnitConfig +initUnitConfig dflags = let autoLink | not (gopt Opt_AutoLinkPackages dflags) = [] -- By default we add base & rts to the preload units (when they are -- found in the unit database) except when we are building them | otherwise = filter (/= homeUnitId dflags) [baseUnitId, rtsUnitId] - pure $ UnitConfig + in UnitConfig { unitConfigPlatformArchOs = platformMini (targetPlatform dflags) , unitConfigProgramName = programName dflags , unitConfigWays = ways dflags @@ -366,11 +370,13 @@ initUnitConfig dflags = do -- instantiated on-the-fly (see Note [About units] in GHC.Unit) , unitConfigAllowVirtualUnits = homeUnitIsIndefinite dflags + , unitConfigDBCache = unitDatabases dflags , unitConfigFlagsDB = packageDBFlags dflags , unitConfigFlagsExposed = packageFlags dflags , unitConfigFlagsIgnored = ignorePackageFlags dflags , unitConfigFlagsTrusted = trustFlags dflags , unitConfigFlagsPlugins = pluginPackageFlags dflags + } -- | Map from 'ModuleName' to a set of of module providers (i.e. a 'Module' and @@ -570,32 +576,18 @@ initUnits :: DynFlags -> IO (DynFlags, [UnitId]) initUnits dflags = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () - (state,dbs) <- withTiming dflags - (text "initializing package database") - forceUnitInfoMap $ do - - cfg <- initUnitConfig dflags - - -- init SDocContext used to render exception messages - let ctx = initSDocContext dflags defaultUserStyle - let printer = debugTraceMsg dflags + let ctx = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages + let printer = debugTraceMsg dflags -- printer for trace messages - -- read the databases if they have not been already read - dbs <- case unitDatabases dflags of - Nothing -> readUnitDatabases printer cfg - Just dbs -> return dbs + (state,dbs) <- withTiming dflags (text "initializing unit database") + forceUnitInfoMap + (mkUnitState ctx printer (initUnitConfig dflags)) - -- create the UnitState - state <- mkUnitState ctx (printer 2) cfg dbs - - return (state, dbs) - - dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map" - FormatText - (pprModuleMap (moduleNameProvidersMap state)) + dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Module Map" + FormatText (pprModuleMap (moduleNameProvidersMap state)) let dflags' = dflags - { unitDatabases = Just dbs + { unitDatabases = Just dbs -- databases are cached and never read again , unitState = state } dflags'' = upd_wired_in_home_instantiations dflags' @@ -1436,14 +1428,11 @@ validateDatabase cfg pkg_map1 = -- settings and populate the package state. mkUnitState - :: SDocContext -- ^ SDocContext used to render exception messages - -> (SDoc -> IO ()) + :: SDocContext -- ^ SDocContext used to render exception messages + -> (Int -> SDoc -> IO ()) -- ^ Trace printer -> UnitConfig - -- initial databases, in the order they were specified on - -- the command line (later databases shadow earlier ones) - -> [UnitDatabase UnitId] - -> IO UnitState -mkUnitState ctx printer cfg raw_dbs = do + -> IO (UnitState,[UnitDatabase UnitId]) +mkUnitState ctx printer cfg = do {- Plan. @@ -1497,6 +1486,10 @@ mkUnitState ctx printer cfg raw_dbs = do we build a mapping saying what every in scope module name points to. -} + -- if databases have not been provided, read the database flags + raw_dbs <- case unitConfigDBCache cfg of + Nothing -> readUnitDatabases printer cfg + Just dbs -> return dbs -- distrust all units if the flag is set let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) } @@ -1508,18 +1501,18 @@ mkUnitState ctx printer cfg raw_dbs = do -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order -- than they are on the command line. let other_flags = reverse (unitConfigFlagsExposed cfg) - printer $ + printer 2 $ text "package flags" <+> ppr other_flags -- Merge databases together, without checking validity - (pkg_map1, prec_map) <- mergeDatabases printer dbs + (pkg_map1, prec_map) <- mergeDatabases (printer 2) dbs -- Now that we've merged everything together, prune out unusable -- packages. let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 - reportCycles printer sccs - reportUnusable printer unusable + reportCycles (printer 2) sccs + reportUnusable (printer 2) unusable -- Apply trust flags (these flags apply regardless of whether -- or not packages are visible or not) @@ -1590,7 +1583,7 @@ mkUnitState ctx printer cfg raw_dbs = do -- it modifies the unit ids of wired in packages, but when we process -- package arguments we need to key against the old versions. -- - (pkgs2, wired_map) <- findWiredInUnits printer prec_map pkgs1 vis_map2 + (pkgs2, wired_map) <- findWiredInUnits (printer 2) prec_map pkgs1 vis_map2 let pkg_db = mkUnitInfoMap pkgs2 -- Update the visibility map, so we treat wired packages as visible. @@ -1664,7 +1657,7 @@ mkUnitState ctx printer cfg raw_dbs = do mod_map = Map.union mod_map1 mod_map2 -- Force the result to avoid leaking input parameters - return $! UnitState + let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs , unitInfoMap = pkg_db @@ -1675,13 +1668,11 @@ mkUnitState ctx printer cfg raw_dbs = do , wireMap = wired_map , unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ] , requirementContext = req_ctx - - -- when the home unit is indefinite, it means we are type-checking it - -- only (not producing any code). Hence we can use virtual units - -- instantiated on-the-fly (see Note [About units] in GHC.Unit) , allowVirtualUnits = unitConfigAllowVirtualUnits cfg } + return (state, raw_dbs) + -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' -- that it was recorded as in the package database. unwireUnit :: UnitState -> Unit-> Unit |