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

5 files changed, 94 insertions, 41 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 0979f92d47..df1ffd5c68 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index dad1d6ff10..a4095f1b10 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index adec051596..53e135c66a 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -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
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index f938bbbda2..5db198be4b 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -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)
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index f684bf7e6f..71be20c20e 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -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