summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC.hs2
-rw-r--r--compiler/GHC/Driver/Backpack.hs4
-rw-r--r--compiler/GHC/Driver/Make.hs83
-rw-r--r--compiler/GHC/Unit/Module/ModIface.hs4
-rw-r--r--ghc/GHCi/Leak.hs4
-rw-r--r--ghc/GHCi/UI.hs20
-rw-r--r--ghc/GHCi/UI/Monad.hs8
-rw-r--r--testsuite/tests/ghci/scripts/T20217.hs3
-rw-r--r--testsuite/tests/ghci/scripts/T20217.script4
-rw-r--r--testsuite/tests/ghci/scripts/T20217.stdout5
-rw-r--r--testsuite/tests/ghci/scripts/T20217A.hs1
-rw-r--r--testsuite/tests/ghci/scripts/T20217A.hs-boot1
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T1
13 files changed, 83 insertions, 57 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 0488ccad11..ad584905a4 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -53,7 +53,7 @@ module GHC (
-- * Loading\/compiling the program
depanal, depanalE,
- load, LoadHowMuch(..), InteractiveImport(..),
+ load, loadWithCache, LoadHowMuch(..), InteractiveImport(..),
SuccessFlag(..), succeeded, failed,
defaultWarnErrLogger, WarnErrLogger,
workingDirectoryChanged,
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 5d0a6a828c..b966a08884 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -323,7 +323,7 @@ buildUnit session cid insts lunit = do
mod_graph <- hsunitModuleGraph (unLoc lunit)
msg <- mkBackpackMsg
- ok <- load' LoadAllTargets (Just msg) mod_graph
+ (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
when (failed ok) (liftIO $ exitWith (ExitFailure 1))
let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
@@ -412,7 +412,7 @@ compileExe lunit = do
withBkpExeSession deps_w_rns $ do
mod_graph <- hsunitModuleGraph (unLoc lunit)
msg <- mkBackpackMsg
- ok <- load' LoadAllTargets (Just msg) mod_graph
+ (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
when (failed ok) (liftIO $ exitWith (ExitFailure 1))
-- | Register a new virtual unit database containing a single unit
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 8918ca1d34..fa1348bfe1 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -27,7 +27,7 @@
-- -----------------------------------------------------------------------------
module GHC.Driver.Make (
depanal, depanalE, depanalPartial,
- load, load', LoadHowMuch(..),
+ load, loadWithCache, load', LoadHowMuch(..),
instantiationNodes,
downsweep,
@@ -87,7 +87,7 @@ import GHC.Data.Maybe ( expectJust )
import GHC.Data.StringBuffer
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Utils.Exception ( evaluate, throwIO, SomeAsyncException )
+import GHC.Utils.Exception ( throwIO, SomeAsyncException )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
@@ -346,11 +346,14 @@ data LoadHowMuch
-- returns together with the errors an empty ModuleGraph.
-- After processing this empty ModuleGraph, the errors of depanalE are thrown.
-- All other errors are reported using the 'defaultWarnErrLogger'.
---
-load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
-load how_much = do
+
+load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
+load how_much = fst <$> loadWithCache [] how_much
+
+loadWithCache :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> m (SuccessFlag, [HomeModInfo])
+loadWithCache cache how_much = do
(errs, mod_graph) <- depanalE [] False -- #17459
- success <- load' how_much (Just batchMsg) mod_graph
+ success <- load' cache how_much (Just batchMsg) mod_graph
if isEmptyMessages errs
then pure success
else throwErrors (fmap GhcDriverMessage errs)
@@ -483,13 +486,12 @@ createBuildPlan mod_graph maybe_top_mod =
-- | Generalized version of 'load' which also supports a custom
-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
-- produced by calling 'depanal'.
-load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
-load' how_much mHscMessage mod_graph = do
+load' :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m (SuccessFlag, [HomeModInfo])
+load' cache how_much mHscMessage mod_graph = do
modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
guessOutputFile
hsc_env <- getSession
- let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
let interp = hscInterp hsc_env
@@ -519,7 +521,7 @@ load' how_much mHscMessage mod_graph = do
| otherwise = do
liftIO $ errorMsg logger
(text "no such module:" <+> quotes (ppr m))
- return Failed
+ return (Failed, [])
checkHowMuch how_much $ do
@@ -545,15 +547,14 @@ load' how_much mHscMessage mod_graph = do
let
-- prune the HPT so everything is not retained when doing an
-- upsweep.
- pruned_hpt = pruneHomePackageTable hpt1
+ !pruned_cache = pruneCache cache
(flattenSCCs (filterToposortToModules mg2_with_srcimps))
- _ <- liftIO $ evaluate pruned_hpt
-- before we unload anything, make sure we don't leave an old
-- interactive context around pointing to dead bindings. Also,
- -- write the pruned HPT to allow the old HPT to be GC'd.
- setSession $ discardIC $ hscUpdateHPT (const pruned_hpt) hsc_env
+ -- write an empty HPT to allow the old HPT to be GC'd.
+ setSession $ discardIC $ hscUpdateHPT (const emptyHomePackageTable) hsc_env
-- Unload everything
liftIO $ unload interp hsc_env
@@ -569,11 +570,12 @@ load' how_much mHscMessage mod_graph = do
setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env
hsc_env <- getSession
- (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $
- liftIO $ upsweep n_jobs hsc_env mHscMessage pruned_hpt direct_deps build_plan
+ (upsweep_ok, hsc_env1, new_cache) <- withDeferredDiagnostics $
+ liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) direct_deps build_plan
setSession hsc_env1
- case upsweep_ok of
+ fmap (, new_cache) $ case upsweep_ok of
Failed -> loadFinish upsweep_ok Succeeded
+
Succeeded -> do
-- Make modsDone be the summaries for each home module now
-- available; this should equal the domain of hpt3.
@@ -730,11 +732,11 @@ guessOutputFile = modifySession $ \env ->
-- space at the end of the upsweep, because the topmost ModDetails of the
-- old HPT holds on to the entire type environment from the previous
-- compilation.
-pruneHomePackageTable :: HomePackageTable
+pruneCache :: [HomeModInfo]
-> [ModSummary]
- -> HomePackageTable
-pruneHomePackageTable hpt summ
- = mapHpt prune hpt
+ -> [HomeModInfo]
+pruneCache hpt summ
+ = strictMap prune hpt
where prune hmi = hmi'{ hm_details = emptyModDetails }
where
modl = moduleName (mi_module (hm_iface hmi))
@@ -922,7 +924,7 @@ withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
-- | Environment used when compiling a module
data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module
- , old_hpt :: !HomePackageTable -- A cache of old interface files
+ , old_hpt :: !(M.Map ModuleNameWithIsBoot HomeModInfo) -- A cache of old interface files
, compile_sem :: !AbstractSem
, lqq_var :: !(TVar LogQueueQueue)
, env_messager :: !(Maybe Messager)
@@ -1030,10 +1032,10 @@ upsweep
:: Int -- ^ The number of workers we wish to run in parallel
-> HscEnv -- ^ The base HscEnv, which is augmented for each module
-> Maybe Messager
- -> HomePackageTable
+ -> M.Map ModuleNameWithIsBoot HomeModInfo
-> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey
-> [BuildPlan]
- -> IO (SuccessFlag, HscEnv)
+ -> IO (SuccessFlag, HscEnv, [HomeModInfo])
upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do
(cycle, pipelines, collect_result) <- interpretBuildPlan direct_deps build_plan
runPipelines n_jobs hsc_env old_hpt mHscMessage pipelines
@@ -1048,10 +1050,13 @@ upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do
Just mss -> do
let logger = hsc_logger hsc_env
liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)
- return (Failed, hsc_env)
+ return (Failed, hsc_env, completed)
Nothing -> do
let success_flag = successIf (all isJust res)
- return (success_flag, hsc_env')
+ return (success_flag, hsc_env', completed)
+
+toCache :: [HomeModInfo] -> M.Map ModuleNameWithIsBoot HomeModInfo
+toCache hmis = M.fromList ([(mi_mnwib $ hm_iface hmi, hmi) | hmi <- hmis])
upsweep_inst :: HscEnv
-> Maybe Messager
@@ -1070,34 +1075,16 @@ upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do
-- successful. If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
-> Maybe Messager
- -> HomePackageTable
+ -> M.Map ModuleNameWithIsBoot HomeModInfo
-> ModSummary
-> Int -- index of module
-> Int -- total number of modules
-> IO HomeModInfo
upsweep_mod hsc_env mHscMessage old_hpt summary mod_index nmods = do
- let old_hmi = lookupHpt old_hpt (ms_mod_name summary)
-
- -- The old interface is ok if
- -- a) we're compiling a source file, and the old HPT
- -- entry is for a source file
- -- b) we're compiling a hs-boot file
- -- Case (b) allows an hs-boot file to get the interface of its
- -- real source file on the second iteration of the compilation
- -- manager, but that does no harm. Otherwise the hs-boot file
- -- will always be recompiled
-
- mb_old_iface
- = case old_hmi of
- Nothing -> Nothing
- Just hm_info | isBootSummary summary == IsBoot -> Just iface
- | mi_boot iface == NotBoot -> Just iface
- | otherwise -> Nothing
- where
- iface = hm_iface hm_info
+ let old_hmi = M.lookup (ms_mnwib summary) old_hpt
hmi <- compileOne' mHscMessage hsc_env summary
- mod_index nmods mb_old_iface (old_hmi >>= hm_linkable)
+ mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable)
-- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module
-- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I
@@ -2368,7 +2355,7 @@ label_self thread_name = do
-- | Build and run a pipeline
runPipelines :: Int -- ^ How many capabilities to use
-> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module
- -> HomePackageTable -- ^ The old HPT which is used as a cache (TODO: The cache should be from the ActionMap)
+ -> M.Map ModuleNameWithIsBoot HomeModInfo -- ^ The old HPT which is used as a cache (TODO: The cache should be from the ActionMap)
-> Maybe Messager -- ^ Optional custom messager to use to report progress
-> [MakeAction] -- ^ The build plan for all the module nodes
-> IO ()
diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs
index 695e1ff6c2..a339df92cc 100644
--- a/compiler/GHC/Unit/Module/ModIface.hs
+++ b/compiler/GHC/Unit/Module/ModIface.hs
@@ -18,6 +18,7 @@ module GHC.Unit.Module.ModIface
, mi_fix
, mi_semantic_module
, mi_free_holes
+ , mi_mnwib
, renameFreeHoles
, emptyPartialModIface
, emptyFullModIface
@@ -262,6 +263,9 @@ mi_boot iface = if mi_hsc_src iface == HsBootFile
then IsBoot
else NotBoot
+mi_mnwib :: ModIface -> ModuleNameWithIsBoot
+mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface)
+
-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be
-- found, 'defaultFixity' is returned instead.
mi_fix :: ModIface -> OccName -> Fixity
diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs
index 6102df9e04..e99ff405aa 100644
--- a/ghc/GHCi/Leak.hs
+++ b/ghc/GHCi/Leak.hs
@@ -59,7 +59,9 @@ checkLeakIndicators dflags (LeakIndicators leakmods) = do
Just hmi ->
report ("HomeModInfo for " ++
showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)
- deRefWeak leakIface >>= report "ModIface"
+ deRefWeak leakIface >>= \case
+ Nothing -> return ()
+ Just miface -> report ("ModIface:" ++ moduleNameString (moduleName (mi_module miface))) (Just miface)
deRefWeak leakDetails >>= report "ModDetails"
forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"
where
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 369002b8bc..4a82a51e84 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -550,7 +550,8 @@ interactiveUI config srcs maybe_exprs = do
lastErrorLocations = lastErrLocationsRef,
mod_infos = M.empty,
flushStdHandles = flush,
- noBuffering = nobuffering
+ noBuffering = nobuffering,
+ hmiCache = []
}
return ()
@@ -1656,6 +1657,12 @@ trySuccess act =
return Failed) $ do
act
+trySuccessWithRes :: (Monoid a, GHC.GhcMonad m) => m (SuccessFlag, a) -> m (SuccessFlag, a)
+trySuccessWithRes act =
+ handleSourceError (\e -> do GHC.printException e
+ return (Failed, mempty))
+ act
+
-----------------------------------------------------------------------------
-- :edit
@@ -2114,7 +2121,10 @@ doLoad retain_context howmuch = do
(\_ ->
liftIO $ do hSetBuffering stdout NoBuffering
hSetBuffering stderr NoBuffering) $ \_ -> do
- ok <- trySuccess $ GHC.load howmuch
+ hmis <- hmiCache <$> getGHCiState
+ modifyGHCiState (\ghci -> ghci { hmiCache = [] })
+ (ok, new_cache) <- trySuccessWithRes $ GHC.loadWithCache hmis howmuch
+ modifyGHCiState (\ghci -> ghci { hmiCache = new_cache })
afterLoad ok retain_context
return ok
@@ -4397,6 +4407,11 @@ discardActiveBreakPoints = do
mapM_ (turnBreakOnOff False) $ breaks st
setGHCiState $ st { breaks = IntMap.empty }
+-- don't reset the counter back to zero?
+discardInterfaceCache :: GhciMonad m => m ()
+discardInterfaceCache = do
+ modifyGHCiState $ (\st -> st { hmiCache = [] })
+
deleteBreak :: GhciMonad m => Int -> m ()
deleteBreak identity = do
st <- getGHCiState
@@ -4579,6 +4594,7 @@ wantNameFromInterpretedModule noCanDo str and_then =
clearAllTargets :: GhciMonad m => m ()
clearAllTargets = discardActiveBreakPoints
+ >> discardInterfaceCache
>> GHC.setTargets []
>> GHC.load LoadAllTargets
>> pure ()
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index a24c40e804..72a44530e6 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -56,6 +56,7 @@ import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
import GHC.Hs.Utils
import GHC.Utils.Misc
import GHC.Utils.Logger
+import GHC.Unit.Home.ModInfo
import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch)
import Numeric
@@ -159,8 +160,9 @@ data GHCiState = GHCiState
flushStdHandles :: ForeignHValue,
-- ^ @hFlush stdout; hFlush stderr@ in the interpreter
- noBuffering :: ForeignHValue
+ noBuffering :: ForeignHValue,
-- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr
+ hmiCache :: [HomeModInfo]
}
type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
@@ -288,7 +290,7 @@ class GhcMonad m => GhciMonad m where
instance GhciMonad GHCi where
getGHCiState = GHCi $ \r -> liftIO $ readIORef r
setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
- modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
+ modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef' r f
reifyGHCi f = GHCi $ \r -> reifyGhc $ \s -> f (s, r)
instance GhciMonad (InputT GHCi) where
@@ -327,7 +329,7 @@ instance GhcMonad (InputT GHCi) where
isOptionSet :: GhciMonad m => GHCiOption -> m Bool
isOptionSet opt
= do st <- getGHCiState
- return (opt `elem` options st)
+ return $! (opt `elem` options st)
setOption :: GhciMonad m => GHCiOption -> m ()
setOption opt
diff --git a/testsuite/tests/ghci/scripts/T20217.hs b/testsuite/tests/ghci/scripts/T20217.hs
new file mode 100644
index 0000000000..4529633222
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217.hs
@@ -0,0 +1,3 @@
+module T20217 where
+
+import {-# SOURCE #-} T20217A
diff --git a/testsuite/tests/ghci/scripts/T20217.script b/testsuite/tests/ghci/scripts/T20217.script
new file mode 100644
index 0000000000..27bffe4e61
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217.script
@@ -0,0 +1,4 @@
+:set -fno-code
+:set -v1
+:l T20217
+:r
diff --git a/testsuite/tests/ghci/scripts/T20217.stdout b/testsuite/tests/ghci/scripts/T20217.stdout
new file mode 100644
index 0000000000..fa229321bf
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217.stdout
@@ -0,0 +1,5 @@
+[1 of 3] Compiling T20217A[boot] ( T20217A.hs-boot, nothing )
+[2 of 3] Compiling T20217 ( T20217.hs, nothing )
+[3 of 3] Compiling T20217A ( T20217A.hs, nothing )
+Ok, three modules loaded.
+Ok, three modules loaded.
diff --git a/testsuite/tests/ghci/scripts/T20217A.hs b/testsuite/tests/ghci/scripts/T20217A.hs
new file mode 100644
index 0000000000..326b0d7607
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217A.hs
@@ -0,0 +1 @@
+module T20217A where x = x
diff --git a/testsuite/tests/ghci/scripts/T20217A.hs-boot b/testsuite/tests/ghci/scripts/T20217A.hs-boot
new file mode 100644
index 0000000000..c4c1f8a75b
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T20217A.hs-boot
@@ -0,0 +1 @@
+module T20217A where
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index d8c80e9543..c47b3b0569 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -346,3 +346,4 @@ test('T19650',
test('T20019', normal, ghci_script, ['T20019.script'])
test('T20101', normal, ghci_script, ['T20101.script'])
test('T20206', normal, ghci_script, ['T20206.script'])
+test('T20217', normal, ghci_script, ['T20217.script'])
View Lorry Controller Status