Commit 3b5f786c authored by Simon Marlow's avatar Simon Marlow Committed by Ben Gamari

Optimise common cases of GHC.setProgramDynFlags

* If the package flags haven't changed, don't do initPackages (which
  might take multiple seconds in extreme cases)

* Provide a way to change the log_action without invalidating the
  summary cache.

Test Plan: validate

Reviewers: niteria, bgamari, austin, erikd, ezyang

Reviewed By: bgamari

Subscribers: mpickering, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3392
parent 83ac4624
......@@ -252,7 +252,15 @@ compileOne' m_tc_result mHscMessage
-- imports a _stub.h file that we created here.
current_dir = takeDirectory basename
old_paths = includePaths dflags1
dflags = dflags1 { includePaths = current_dir : old_paths }
prevailing_dflags = hsc_dflags hsc_env0
dflags =
dflags1 { includePaths = current_dir : old_paths
, log_action = log_action prevailing_dflags
, log_finaliser = log_finaliser prevailing_dflags }
-- use the prevailing log_action / log_finaliser,
-- not the one cached in the summary. This is so
-- that we can change the log_action without having
-- to re-summarize all the source files.
hsc_env = hsc_env0 {hsc_dflags = dflags}
-- Figure out what lang we're generating
......
......@@ -24,7 +24,7 @@ module DynFlags (
WarningFlag(..), WarnReason(..),
Language(..),
PlatformConstants(..),
FatalMessager, LogAction, FlushOut(..), FlushErr(..),
FatalMessager, LogAction, LogFinaliser, FlushOut(..), FlushErr(..),
ProfAuto(..),
glasgowExtsFlags,
warningGroups, warningHierarchies,
......@@ -48,8 +48,9 @@ module DynFlags (
GhcMode(..), isOneShot,
GhcLink(..), isNoLink,
PackageFlag(..), PackageArg(..), ModRenaming(..),
packageFlagsChanged,
IgnorePackageFlag(..), TrustFlag(..),
PkgConfRef(..),
PackageDBFlag(..), PkgConfRef(..),
Option(..), showOpt,
DynLibLoader(..),
fFlags, fLangFlags, xFlags,
......@@ -806,15 +807,12 @@ data DynFlags = DynFlags {
depSuffixes :: [String],
-- Package flags
extraPkgConfs :: [PkgConfRef] -> [PkgConfRef],
-- ^ The @-package-db@ flags given on the command line, in the order
-- they appeared. In *reverse* order that they're specified
-- on the command line. This is intended to be applied with the
-- list of "initial" package databases derived from @GHC_PACKAGE_PATH@;
-- see 'getPackageConfRefs'; this is a function because 'extraPkgConfs'
-- maybe configured to filter out certain flags from *either* the
-- user command line, or the base command; see for example
-- 'removeUserPkgConf'.
packageDBFlags :: [PackageDBFlag],
-- ^ The @-package-db@ flags given on the command line, In
-- *reverse* order that they're specified on the command line.
-- This is intended to be applied with the list of "initial"
-- package databases derived from @GHC_PACKAGE_PATH@; see
-- 'getPackageConfRefs'.
ignorePackageFlags :: [IgnorePackageFlag],
-- ^ The @-ignore-package@ flags from the command line.
......@@ -1256,9 +1254,28 @@ data TrustFlag
data PackageFlag
= ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@
| HidePackage String -- ^ @-hide-package@
deriving (Eq) -- NB: equality instance is used by packageFlagsChanged
data PackageDBFlag
= PackageDB PkgConfRef
| NoUserPackageDB
| NoGlobalPackageDB
| ClearPackageDBs
deriving (Eq)
-- NB: equality instance is used by InteractiveUI to test if
-- package flags have changed.
packageFlagsChanged :: DynFlags -> DynFlags -> Bool
packageFlagsChanged idflags1 idflags0 =
packageFlags idflags1 /= packageFlags idflags0 ||
ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||
pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||
trustFlags idflags1 /= trustFlags idflags0 ||
packageDBFlags idflags1 /= packageDBFlags idflags0 ||
packageGFlags idflags1 /= packageGFlags idflags0
where
packageGFlags dflags = map (`gopt` dflags)
[ Opt_HideAllPackages
, Opt_HideAllPluginPackages
, Opt_AutoLinkPackages ]
instance Outputable PackageFlag where
ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)
......@@ -1607,7 +1624,7 @@ defaultDynFlags mySettings =
hpcDir = ".hpc",
extraPkgConfs = id,
packageDBFlags = [],
packageFlags = [],
pluginPackageFlags = [],
ignorePackageFlags = [],
......@@ -4538,24 +4555,23 @@ data PkgConfRef
= GlobalPkgConf
| UserPkgConf
| PkgConfFile FilePath
deriving Eq
addPkgConfRef :: PkgConfRef -> DynP ()
addPkgConfRef p = upd $ \s -> s { extraPkgConfs = (p:) . extraPkgConfs s }
addPkgConfRef p = upd $ \s ->
s { packageDBFlags = PackageDB p : packageDBFlags s }
removeUserPkgConf :: DynP ()
removeUserPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotUser . extraPkgConfs s }
where
isNotUser UserPkgConf = False
isNotUser _ = True
removeUserPkgConf = upd $ \s ->
s { packageDBFlags = NoUserPackageDB : packageDBFlags s }
removeGlobalPkgConf :: DynP ()
removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extraPkgConfs s }
where
isNotGlobal GlobalPkgConf = False
isNotGlobal _ = True
removeGlobalPkgConf = upd $ \s ->
s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s }
clearPkgConf :: DynP ()
clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
clearPkgConf = upd $ \s ->
s { packageDBFlags = ClearPackageDBs : packageDBFlags s }
parsePackageFlag :: String -- the flag
-> ReadP PackageArg -- type of argument
......
......@@ -29,7 +29,7 @@ module GHC (
GhcMode(..), GhcLink(..), defaultObjectTarget,
parseDynamicFlags,
getSessionDynFlags, setSessionDynFlags,
getProgramDynFlags, setProgramDynFlags,
getProgramDynFlags, setProgramDynFlags, setLogAction,
getInteractiveDynFlags, setInteractiveDynFlags,
-- * Targets
......@@ -567,15 +567,35 @@ setSessionDynFlags dflags = do
invalidateModSummaryCache
return preload
-- | Sets the program 'DynFlags'.
-- | 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 dflags = do
setProgramDynFlags dflags = setProgramDynFlags_ True dflags
-- | Set the action taken when the compiler produces a message. This
-- can also be accomplished using 'setProgramDynFlags', but using
-- 'setLogAction' avoids invalidating the cached module graph.
setLogAction :: GhcMonad m => LogAction -> LogFinaliser -> m ()
setLogAction action finaliser = do
dflags' <- getProgramDynFlags
void $ setProgramDynFlags_ False $
dflags' { log_action = action
, log_finaliser = finaliser }
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
setProgramDynFlags_ invalidate_needed dflags = do
dflags' <- checkNewDynFlags dflags
(dflags'', preload) <- liftIO $ initPackages dflags'
dflags_prev <- getProgramDynFlags
(dflags'', preload) <-
if (packageFlagsChanged dflags_prev dflags')
then liftIO $ initPackages dflags'
else return (dflags', [])
modifySession $ \h -> h{ hsc_dflags = dflags'' }
invalidateModSummaryCache
when invalidate_needed $ invalidateModSummaryCache
return preload
-- When changing the DynFlags, we want the changes to apply to future
-- loads, but without completely discarding the program. But the
-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so
......
......@@ -500,10 +500,26 @@ getPackageConfRefs dflags = do
| otherwise
-> map PkgConfFile (splitSearchPath path)
return $ reverse (extraPkgConfs dflags base_conf_refs)
-- later packages shadow earlier ones. extraPkgConfs
-- is in the opposite order to the flags on the
-- command line.
-- Apply the package DB-related flags from the command line to get the
-- final list of package DBs.
--
-- Notes on ordering:
-- * The list of flags is reversed (later ones first)
-- * We work with the package DB list in "left shadows right" order
-- * and finally reverse it at the end, to get "right shadows left"
--
return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags))
where
doFlag (PackageDB p) dbs = p : dbs
doFlag NoUserPackageDB dbs = filter isNotUser dbs
doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs
doFlag ClearPackageDBs _ = []
isNotUser UserPkgConf = False
isNotUser _ = True
isNotGlobal GlobalPkgConf = False
isNotGlobal _ = True
resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
......
......@@ -2593,13 +2593,6 @@ setOptions wds =
-- then, dynamic flags
when (not (null minus_opts)) $ newDynFlags False minus_opts
packageFlagsChanged :: DynFlags -> DynFlags -> Bool
packageFlagsChanged idflags1 idflags0 =
packageFlags idflags1 /= packageFlags idflags0 ||
ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||
pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||
trustFlags idflags1 /= trustFlags idflags0
newDynFlags :: Bool -> [String] -> GHCi ()
newDynFlags interactive_only minus_opts = do
let lopts = map noLoc minus_opts
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment