Commit 914842e5 authored by Simon Marlow's avatar Simon Marlow

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
parent 583fa9e3
......@@ -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
......
......@@ -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'])
......
:! 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
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