Don't setProgramDynFlags on every :load

Summary:
setProgramDynFlags invalidates the whole module graph, forcing
everything to be re-summarised (including preprocessing) on every
:reload.

Looks like this was a bad regression in 8.0, but we didn't notice
because there was no test for it.  Now there is!

Test Plan:
* validate
* new unit test

Reviewers: bgamari, triple, austin, niteria, erikd, jme

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3398

3 files changed, 46 insertions, 19 deletions

diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index aeab85b..99786b5 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -104,7 +104,7 @@ import Data.Time.Format ( formatTime, defaultTimeLocale )
 import Data.Version ( showVersion )
 
 import Exception hiding (catch)
-import Foreign
+import Foreign hiding (void)
 import GHC.Stack hiding (SrcLoc(..))
 
 import System.Directory
@@ -186,15 +186,15 @@ ghciCommands = map mkCmd [
   ("issafe",    keepGoing' isSafeCmd,           completeModule),
   ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
   ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
-  ("load",      keepGoingPaths (loadModule_ False), completeHomeModuleOrFile),
-  ("load!",     keepGoingPaths (loadModule_ True), completeHomeModuleOrFile),
+  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
+  ("load!",     keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),
   ("list",      keepGoing' listCmd,             noCompletion),
   ("module",    keepGoing moduleCmd,            completeSetModule),
   ("main",      keepGoing runMain,              completeFilename),
   ("print",     keepGoing printCmd,             completeExpression),
   ("quit",      quit,                           noCompletion),
-  ("reload",    keepGoing' (reloadModule False), noCompletion),
-  ("reload!",   keepGoing' (reloadModule True), noCompletion),
+  ("reload",    keepGoing' reloadModule,        noCompletion),
+  ("reload!",   keepGoing' reloadModuleDefer,   noCompletion),
   ("run",       keepGoing runRun,               completeFilename),
   ("script",    keepGoing' scriptCmd,           completeFilename),
   ("set",       keepGoing setCmd,               completeSetOptions),
@@ -1444,7 +1444,7 @@ editFile str =
      code <- liftIO $ system (cmd ++ cmdArgs)
 
      when (code == ExitSuccess)
-       $ reloadModule False ""
+       $ reloadModule ""
 
 -- The user didn't specify a file so we pick one for them.
 -- Our strategy is to pick the first module that failed to load,
@@ -1604,21 +1604,27 @@ checkModule m = do
 
 -- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets
 -- '-fdefer-type-errors' again if it has not been set before.
-deferredLoad :: Bool -> InputT GHCi SuccessFlag -> InputT GHCi ()
-deferredLoad defer load = do
-  -- Force originalFlags to avoid leaking the associated HscEnv
-  !originalFlags <- getDynFlags
-  when defer $ Monad.void $
-    GHC.setProgramDynFlags $ setGeneralFlag' Opt_DeferTypeErrors originalFlags
-  Monad.void $ load
-  Monad.void $ GHC.setProgramDynFlags $ originalFlags
+wrapDeferTypeErrors :: InputT GHCi a -> InputT GHCi a
+wrapDeferTypeErrors load =
+  gbracket
+    (do
+      -- Force originalFlags to avoid leaking the associated HscEnv
+      !originalFlags <- getDynFlags
+      void $ GHC.setProgramDynFlags $
+         setGeneralFlag' Opt_DeferTypeErrors originalFlags
+      return originalFlags)
+    (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)
+    (\_ -> load)
 
 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
 loadModule fs = timeIt (const Nothing) (loadModule' fs)
 
 -- | @:load@ command
-loadModule_ :: Bool -> [FilePath] -> InputT GHCi ()
-loadModule_ defer fs = deferredLoad defer (loadModule (zip fs (repeat Nothing)))
+loadModule_ :: [FilePath] -> InputT GHCi ()
+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))
+
+loadModuleDefer :: [FilePath] -> InputT GHCi ()
+loadModuleDefer = wrapDeferTypeErrors . loadModule_
 
 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
 loadModule' files = do
@@ -1654,13 +1660,15 @@ addModule files = do
   return ()
 
 -- | @:reload@ command
-reloadModule :: Bool -> String -> InputT GHCi ()
-reloadModule defer m = deferredLoad defer $
-                       doLoadAndCollectInfo True loadTargets
+reloadModule :: String -> InputT GHCi ()
+reloadModule m = void $ doLoadAndCollectInfo True loadTargets
   where
     loadTargets | null m    = LoadAllTargets
                 | otherwise = LoadUpTo (GHC.mkModuleName m)
 
+reloadModuleDefer :: String -> InputT GHCi ()
+reloadModuleDefer = wrapDeferTypeErrors . reloadModule
+
 -- | Load/compile targets and (optionally) collect module-info
 --
 -- This collects the necessary SrcSpan annotated type information (via
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 16c9ab2..917537b 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -97,6 +97,7 @@ test('ghci061', normal, ghci_script, ['ghci061.script'])
 test('ghci062', [extra_files(['ghci062/', 'ghci062/Test.hs']),
                  when(config.have_ext_interp, extra_ways(['ghci-ext']))],
 		ghci_script, ['ghci062.script'])
+test('ghci063', normal, ghci_script, ['ghci063.script'])
 
 test('T2452', normal, ghci_script, ['T2452.script'])
 test('T2766', normal, ghci_script, ['T2766.script'])
diff --git a/testsuite/tests/ghci/scripts/ghci063.script b/testsuite/tests/ghci/scripts/ghci063.script
new file mode 100644
index 0000000..87a19ba
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/ghci063.script
@@ -0,0 +1,18 @@
+:! echo module A where {} >A.hs
+:! echo module B where { import A } >B.hs
+
+:load B
+
+-- We're going to replace B.hs with an invalid module but without
+-- changing its timestamp.  A :reload should *not* look at the
+-- contents of the file, because the timestamp hasn't changed.
+:! cp B.hs B.hs-copy
+:! touch -r B.hs B.hs-copy
+:! echo "*** INVALID ***" >B.hs
+:! touch -r B.hs-copy B.hs
+
+:reload
+
+-- Put the original file back, now it should work
+:! cp B.hs-copy B.hs
+:reload