diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-05-05 14:02:37 +0100 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2021-06-03 08:46:47 +0100 |
| commit | 25977ab542a30df4ae71d9699d015bcdd1ab7cfb (patch) | |
| tree | fc2195f9ceb5651603aa5fed03580eb47e0412d7 | |
| parent | 79d12d34ad7177d33b191305f2c0157349f97355 (diff) | |
| download | haskell-25977ab542a30df4ae71d9699d015bcdd1ab7cfb.tar.gz | |
Driver Rework Patch
This patch comprises of four different but closely related ideas. The
net result is fixing a large number of open issues with the driver
whilst making it simpler to understand.
1. Use the hash of the source file to determine whether the source file
has changed or not. This makes the recompilation checking more robust to
modern build systems which are liable to copy files around changing
their modification times.
2. Remove the concept of a "stable module", a stable module was one
where the object file was older than the source file, and all transitive
dependencies were also stable. Now we don't rely on the modification
time of the source file, the notion of stability is moot.
3. Fix TH/plugin recompilation after the removal of stable modules. The
TH recompilation check used to rely on stable modules. Now there is a
uniform and simple way, we directly track the linkables which were
loaded into the interpreter whilst compiling a module. This is an
over-approximation but more robust wrt package dependencies changing.
4. Fix recompilation checking for dynamic object files. Now we actually
check if the dynamic object file exists when compiling with -dynamic-too
Fixes #19774 #19771 #19758 #17434 #11556 #9121 #8211 #16495 #7277 #16093
180 files changed, 1830 insertions, 1061 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index f71caa6f15..7e882dbd8b 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -57,7 +57,7 @@ module GHC ( SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, - parseModule, typecheckModule, desugarModule, loadModule, + parseModule, typecheckModule, desugarModule, ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), TypecheckedSource, ParsedSource, RenamedSource, -- ditto TypecheckedMod, ParsedMod, @@ -314,7 +314,6 @@ import GHC.Driver.Config import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Hooks -import GHC.Driver.Pipeline ( compileOne' ) import GHC.Driver.Monad import GHC.Driver.Ppr @@ -357,6 +356,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Utils.Fingerprint import GHC.Core.Predicate import GHC.Core.Type hiding( typeKind ) @@ -387,7 +387,6 @@ import GHC.Types.TyThing import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.TypeEnv -import GHC.Types.SourceFile import GHC.Unit import GHC.Unit.Env @@ -407,7 +406,6 @@ import Data.Set (Set) import qualified Data.Set as S import qualified Data.Sequence as Seq import Data.Maybe -import Data.Time import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import Control.Monad @@ -750,7 +748,7 @@ setProgramDynFlags_ invalidate_needed dflags = do -- old log_action. This is definitely wrong (#7478). -- -- Hence, we invalidate the ModSummary cache after changing the --- DynFlags. We do this by tweaking the date on each ModSummary, so +-- DynFlags. We do this by tweaking the hash on each ModSummary, so -- that the next downsweep will think that all the files have changed -- and preprocess them again. This won't necessarily cause everything -- to be recompiled, because by the time we check whether we need to @@ -761,7 +759,7 @@ invalidateModSummaryCache :: GhcMonad m => m () invalidateModSummaryCache = modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } where - inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) } + inval ms = ms { ms_hs_hash = fingerprint0 } -- | Returns the program 'DynFlags'. getProgramDynFlags :: GhcMonad m => m DynFlags @@ -783,7 +781,7 @@ setInteractiveDynFlags dflags = do -- Initialise (load) plugins in the interactive environment with the new -- DynFlags - plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ + plugin_env <- liftIO $ flip initializePlugins Nothing $ mkInteractiveHscEnv $ hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }} -- Update both plugins cache and DynFlags in the interactive context. @@ -1185,41 +1183,6 @@ desugarModule tcm = do dm_core_module = guts } --- | Load a module. Input doesn't need to be desugared. --- --- A module must be loaded before dependent modules can be typechecked. This --- always includes generating a 'ModIface' and, depending on the --- @DynFlags@\'s 'GHC.Driver.Session.backend', may also include code generation. --- --- This function will always cause recompilation and will always overwrite --- previous compilation results (potentially files on disk). --- -loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod -loadModule tcm = do - let ms = modSummary tcm - let mod = ms_mod_name ms - let loc = ms_location ms - let (tcg, _details) = tm_internals tcm - - mb_linkable <- case ms_obj_date ms of - Just t | t > ms_hs_date ms -> do - l <- liftIO $ findObjectLinkable (ms_mod ms) - (ml_obj_file loc) t - return (Just l) - _otherwise -> return Nothing - - let source_modified | isNothing mb_linkable = SourceModified - | otherwise = SourceUnmodified - -- we can't determine stability here - - -- compile doesn't change the session - hsc_env <- getSession - mod_info <- liftIO $ compileOne' (Just tcg) Nothing - hsc_env ms 1 1 Nothing mb_linkable - source_modified - - modifySession $ hscUpdateHPT (\hpt -> addToHpt hpt mod mod_info) - return tcm -- %************************************************************************ diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs index c2dd8e2208..749f64b09e 100644 --- a/compiler/GHC/Data/StringBuffer.hs +++ b/compiler/GHC/Data/StringBuffer.hs @@ -32,6 +32,7 @@ module GHC.Data.StringBuffer currentChar, prevChar, atEnd, + fingerprintStringBuffer, -- * Moving and comparison stepOn, @@ -55,6 +56,7 @@ import GHC.Utils.Encoding import GHC.Utils.IO.Unsafe import GHC.Utils.Panic.Plain import GHC.Utils.Exception ( bracket_ ) +import GHC.Fingerprint import Data.Maybe import System.IO @@ -256,6 +258,13 @@ byteDiff s1 s2 = cur s2 - cur s1 atEnd :: StringBuffer -> Bool atEnd (StringBuffer _ l c) = l == c +-- | Computes a hash of the contents of a 'StringBuffer'. +fingerprintStringBuffer :: StringBuffer -> Fingerprint +fingerprintStringBuffer (StringBuffer buf len cur) = + unsafePerformIO $ + withForeignPtr buf $ \ptr -> + fingerprintData (ptr `plusPtr` cur) len + -- | Computes a 'StringBuffer' which points to the first character of the -- wanted line. Lines begin at 1. atLine :: Int -> StringBuffer -> Maybe StringBuffer diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index dceed41099..1d5b567359 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -50,6 +50,7 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.DSet import GHC.Utils.Outputable +import GHC.Utils.Fingerprint import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Error @@ -184,6 +185,9 @@ withBkpSession cid insts deps session_type do_this = do { backend = case session_type of TcSession -> NoBackend _ -> backend dflags + , ghcLink = case session_type of + TcSession -> NoLink + _ -> ghcLink dflags , homeUnitInstantiations_ = insts -- if we don't have any instantiation, don't -- fill `homeUnitInstanceOfId` as it makes no @@ -333,7 +337,7 @@ buildUnit session cid insts lunit = do linkables = map (expectJust "bkp link" . hm_linkable) . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) $ home_mod_infos - getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables state = hsc_units hsc_env @@ -751,7 +755,7 @@ summariseRequirement pn mod_name = do (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig" env <- getBkpEnv - time <- liftIO $ getModificationUTCTime (bkp_filename env) + src_hash <- liftIO $ getFileHash (bkp_filename env) hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) @@ -765,8 +769,9 @@ summariseRequirement pn mod_name = do ms_mod = mod, ms_hsc_src = HsigFile, ms_location = location, - ms_hs_date = time, + ms_hs_hash = src_hash, ms_obj_date = Nothing, + ms_dyn_obj_date = Nothing, ms_iface_date = hi_timestamp, ms_hie_date = hie_timestamp, ms_srcimps = [], @@ -802,7 +807,6 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing emptyModNodeMap -- GHC API recomp not supported (hscSourceToIsBoot hsc_src) lmodname - True -- Target lets you disallow, but not here Nothing -- GHC API buffer support not supported [] -- No exclusions case r of @@ -849,7 +853,7 @@ hsModuleToModSummary pn hsc_src modname _ -> location0 -- This duplicates a pile of logic in GHC.Driver.Make env <- getBkpEnv - time <- liftIO $ getModificationUTCTime (bkp_filename env) + src_hash <- liftIO $ getFileHash (bkp_filename env) hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) @@ -898,8 +902,9 @@ hsModuleToModSummary pn hsc_src modname hpm_module = hsmod, hpm_src_files = [] -- TODO if we preprocessed it }), - ms_hs_date = time, + ms_hs_hash = src_hash, ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS + ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS ms_iface_date = hi_timestamp, ms_hie_date = hie_timestamp } diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index 942c9810a5..6730daca5c 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -135,14 +135,14 @@ data Hooks = Hooks -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))) , hscFrontendHook :: !(Maybe (ModSummary -> Hsc FrontendResult)) , hscCompileCoreExprHook :: - !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)) + !(Maybe (HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CoreExpr -> IO ForeignHValue)) , ghcPrimIfaceHook :: !(Maybe ModIface) , runPhaseHook :: !(Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath))) , runMetaHook :: !(Maybe (MetaHook TcM)) , linkHook :: !(Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)) , runRnSpliceHook :: !(Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))) - , getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type + , getValueSafelyHook :: !(Maybe (HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Maybe HValue))) , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) , stgToCmmHook :: !(Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index e97fb5a4c6..3c6bacdf6a 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fprof-auto-top #-} @@ -88,6 +89,7 @@ module GHC.Driver.Main , ioMsgMaybe , showModuleIndex , hscAddSptEntries + , writeInterfaceOnlyMode ) where import GHC.Prelude @@ -218,6 +220,7 @@ import GHC.Data.Bag import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) +import qualified GHC.SysTools import Data.Data hiding (Fixity, TyCon) import Data.Maybe ( fromJust ) @@ -544,7 +547,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do Nothing -> hscParse' mod_summary tc_result0 <- tcRnModule' mod_summary keep_rn' hpm if hsc_src == HsigFile - then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing + then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary Nothing ioMsgMaybe $ hoistTcRnMessage $ tcRnMergeSignatures hsc_env hpm tc_result0 iface else return tc_result0 @@ -680,15 +683,17 @@ This is the only thing that isn't caught by the type-system. type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () -- | Do the recompilation avoidance checks for both one-shot and --make modes +-- This function is the *only* place in the compiler where we decide whether to +-- recompile a module or not! hscRecompStatus :: Maybe Messager -> HscEnv -> ModSummary - -> SourceModified -> Maybe ModIface + -> Maybe Linkable -> (Int,Int) -> IO HscRecompStatus hscRecompStatus - mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index + mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index = do let msg what = case mHscMessage of @@ -696,24 +701,86 @@ hscRecompStatus Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary)) Nothing -> return () - (recomp_reqd, mb_checked_iface) - <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary - source_modified mb_old_iface - + -- First check to see if the interface file agrees with the + -- source file. + (recomp_iface_reqd, mb_checked_iface) + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary mb_old_iface + -- Check to see whether the expected build products already exist. + -- If they don't exists then we trigger recompilation. + let lcl_dflags = ms_hspp_opts mod_summary + (recomp_obj_reqd, mb_linkable) <- + case () of + -- No need for a linkable, we're good to go + _ | writeInterfaceOnlyMode lcl_dflags -> return (UpToDate, Nothing) + -- Interpreter can use either already loaded bytecode or loaded object code + | not (backendProducesObject (backend lcl_dflags)) -> do + res <- liftIO $ checkByteCode old_linkable + case res of + (_, Just{}) -> return res + _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary + -- Need object files for making object files + | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary + | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags) + let recomp_reqd = recomp_iface_reqd `mappend` recomp_obj_reqd -- save the interface that comes back from checkOldIface. -- In one-shot mode we don't have the old iface until this -- point, when checkOldIface reads it from the disk. let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface - msg recomp_reqd case mb_checked_iface of - Just iface | not (recompileRequired recomp_reqd) -> do - -- We didn't need to do any typechecking; the old interface - -- file on disk was good enough. - return $ HscUpToDate iface + Just iface | not (recompileRequired recomp_reqd) -> + return $ HscUpToDate iface mb_linkable + _ -> + return $ HscRecompNeeded mb_old_hash + +-- | Check that the .o files produced by compilation are already up-to-date +-- or not. +checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (RecompileRequired, Maybe Linkable) +checkObjects dflags mb_old_linkable summary = do + dt_state <- dynamicTooState dflags + let + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + mb_dyn_obj_date = ms_dyn_obj_date summary + mb_if_date = ms_iface_date summary + obj_fn = ml_obj_file (ms_location summary) + -- dynamic-too *also* produces the dyn_o_file, so have to check + -- that's there, and if it's not, regenerate both .o and + -- .dyn_o + checkDynamicObj k = case dt_state of + DT_OK -> case (>=) <$> mb_dyn_obj_date <*> mb_if_date of + Just True -> k + _ -> return (RecompBecause "Missing dynamic object", Nothing) + -- Not in dynamic-too mode + _ -> k + + checkDynamicObj $ + case (,) <$> mb_obj_date <*> mb_if_date of + Just (obj_date, if_date) + | obj_date >= if_date -> + case mb_old_linkable of + Just old_linkable + | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date + -> return $ (UpToDate, Just old_linkable) + _ -> (UpToDate,) . Just <$> findObjectLinkable this_mod obj_fn obj_date + _ -> return (RecompBecause "Missing object file", Nothing) + +-- | Check to see if we can reuse the old linkable, by this point we will +-- have just checked that the old interface matches up with the source hash, so +-- no need to check that again here +checkByteCode :: Maybe Linkable -> IO (RecompileRequired, Maybe Linkable) +checkByteCode mb_old_linkable = + case mb_old_linkable of + Just old_linkable + | not (isObjectLinkable old_linkable) + -> return $ (UpToDate, Just old_linkable) + _ -> return $ (RecompBecause "Missing bytecode", Nothing) + +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- - _ -> return $ HscRecompNeeded mb_old_hash -- Knot tying! See Note [Knot-tying typecheckIface] -- See Note [ModDetails and --make mode] @@ -828,7 +895,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h {-# SCC "GHC.Driver.Main.mkPartialIface" #-} -- This `force` saves 2M residency in test T10370 -- See Note [Avoiding space leaks in toIface*] for details. - force (mkPartialIface hsc_env details simplified_guts) + force (mkPartialIface hsc_env details summary simplified_guts) return HscRecomp { hscs_guts = cg_guts, hscs_mod_location = ms_location summary, @@ -840,7 +907,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h -- and generate a simple interface. _ -> do (iface, mb_old_iface_hash, _details) <- liftIO $ - hscSimpleIface hsc_env tc_result mb_old_hash + hscSimpleIface hsc_env tc_result summary mb_old_hash liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary) @@ -960,6 +1027,22 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do DT_Failed | not (dynamicNow dflags) -> write_iface dflags iface _ -> return () + when (gopt Opt_WriteHie dflags) $ do + -- This is slightly hacky. A hie file is considered to be up to date + -- if its modification time on disk is greater than or equal to that + -- of the .hi file (since we should always write a .hi file if we are + -- writing a .hie file). However, with the way this code is + -- structured at the moment, the .hie file is often written before + -- the .hi file; by touching the file here, we ensure that it is + -- correctly considered up-to-date. + -- + -- The file should exist by the time we get here, but we check for + -- existence just in case, so that we don't accidentally create empty + -- .hie files. + let hie_file = ml_hie_file mod_location + whenM (doesFileExist hie_file) $ + GHC.SysTools.touch logger dflags "Touching hie file" hie_file + -------------------------------------------------------------- -- NoRecomp handlers -------------------------------------------------------------- @@ -1435,7 +1518,7 @@ hscSimplify' plugins ds_result = do hsc_env <- getHscEnv hsc_env_with_plugins <- if null plugins -- fast path then return hsc_env - else liftIO $ initializePlugins $ hsc_env + else liftIO $ flip initializePlugins (Just $ mg_mnwib ds_result) $ hsc_env { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins } {-# SCC "Core2Core" #-} @@ -1449,22 +1532,24 @@ hscSimplify' plugins ds_result = do -- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] hscSimpleIface :: HscEnv -> TcGblEnv + -> ModSummary -> Maybe Fingerprint -> IO (ModIface, Maybe Fingerprint, ModDetails) -hscSimpleIface hsc_env tc_result mb_old_iface - = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface +hscSimpleIface hsc_env tc_result summary mb_old_iface + = runHsc hsc_env $ hscSimpleIface' tc_result summary mb_old_iface hscSimpleIface' :: TcGblEnv + -> ModSummary -> Maybe Fingerprint -> Hsc (ModIface, Maybe Fingerprint, ModDetails) -hscSimpleIface' tc_result mb_old_iface = do +hscSimpleIface' tc_result summary mb_old_iface = do hsc_env <- getHscEnv details <- liftIO $ mkBootModDetailsTc hsc_env tc_result safe_mode <- hscGetSafeMode tc_result new_iface <- {-# SCC "MkFinalIface" #-} liftIO $ - mkIfaceTc hsc_env safe_mode details tc_result + mkIfaceTc hsc_env safe_mode details summary tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, mb_old_iface, details) @@ -1821,7 +1906,7 @@ hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do -- for linking, else we try to link 'main' and can't find it. -- Whereas the linker already knows to ignore 'interactive' let src_span = srcLocSpan interactiveSrcLoc - hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + hval <- liftIO $ hscCompileCoreExpr hsc_env (src_span, Nothing) ds_expr return $ Just (ids, hval, fix_env) @@ -1910,10 +1995,10 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do stg_binds data_tycons mod_breaks let src_span = srcLocSpan interactiveSrcLoc - liftIO $ loadDecls interp hsc_env src_span cbc + liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc {- Load static pointer table entries -} - liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) + liftIO $ hscAddSptEntries hsc_env Nothing (cg_spt_entries tidy_cg) let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) patsyns = mg_patsyns simpl_mg @@ -1938,12 +2023,12 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do -- | Load the given static-pointer table entries into the interpreter. -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". -hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () -hscAddSptEntries hsc_env entries = do +hscAddSptEntries :: HscEnv -> Maybe ModuleNameWithIsBoot -> [SptEntry] -> IO () +hscAddSptEntries hsc_env mnwib entries = do let interp = hscInterp hsc_env let add_spt_entry :: SptEntry -> IO () add_spt_entry (SptEntry i fpr) = do - val <- loadName interp hsc_env (idName i) + val <- loadName interp hsc_env mnwib (idName i) addSptEntry interp fpr val mapM_ add_spt_entry entries @@ -2054,13 +2139,13 @@ hscParseThingWithLocation source linenumber parser str = do %* * %********************************************************************* -} -hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr :: HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr hsc_env loc expr = case hscCompileCoreExprHook (hsc_hooks hsc_env) of Nothing -> hscCompileCoreExpr' hsc_env loc expr Just h -> h hsc_env loc expr -hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr' :: HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr' hsc_env srcspan ds_expr = do { {- Simplify it -} -- Question: should we call SimpleOpt.simpleOptExpr here instead? @@ -2130,3 +2215,8 @@ showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text -- compute the length of x > 0 in base 10 len x = ceiling (logBase 10 (fromIntegral x+1) :: Float) pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr + +writeInterfaceOnlyMode :: DynFlags -> Bool +writeInterfaceOnlyMode dflags = + gopt Opt_WriteInterface dflags && + NoBackend == backend dflags diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 538c06f951..a76c128dbe 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -75,7 +75,7 @@ import GHC.Data.Maybe ( expectJust ) import GHC.Data.StringBuffer import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.Exception ( tryIO, AsyncException(..), evaluate ) +import GHC.Utils.Exception ( AsyncException(..), evaluate ) import GHC.Utils.Monad ( allM ) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -83,6 +83,7 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Logger +import GHC.Utils.Fingerprint import GHC.Utils.TmpFs import GHC.Utils.Constants (isWindowsHost) @@ -132,7 +133,6 @@ import Data.Bifunctor (first) import System.Directory import System.FilePath import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) @@ -454,16 +454,12 @@ load' how_much mHscMessage mod_graph = do -- are definitely unnecessary, then emit a warning. warnUnnecessarySourceImports mg2_with_srcimps - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - -- prune bits of the HPT which are definitely redundant now, - -- to save space. + let + -- prune the HPT so everything is not retained when doing an + -- upsweep. pruned_hpt = pruneHomePackageTable hpt1 (flattenSCCs mg2_with_srcimps) - stable_mods _ <- liftIO $ evaluate pruned_hpt @@ -472,19 +468,9 @@ load' how_much mHscMessage mod_graph = do -- write the pruned HPT to allow the old HPT to be GC'd. setSession $ discardIC $ hscUpdateHPT (const pruned_hpt) hsc_env - liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) + -- Unload everything + liftIO $ unload interp hsc_env - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- nonDetEltsUniqSet stable_obj ++ - nonDetEltsUniqSet stable_bco, - -- It's OK to use nonDetEltsUniqSet here - -- because it only affects linking. Besides - -- this list only serves as a poor man's set. - Just hmi <- [lookupHpt pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload interp hsc_env stable_linkables -- We could at this point detect cycles which aren't broken by -- a source-import, and complain immediately, but it seems better @@ -500,11 +486,7 @@ load' how_much mHscMessage mod_graph = do -- nodes, and possibly just including the portion of the graph -- reachable from the module specified in the 2nd argument to load. -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg, partial_mg0, partial_mg, unstable_mg :: [SCC ModuleGraphNode] - stable_mg :: [SCC ExtendedModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing + let partial_mg0, partial_mg:: [SCC ModuleGraphNode] maybe_top_mod = case how_much of LoadUpTo m -> Just m @@ -514,8 +496,7 @@ load' how_much mHscMessage mod_graph = do partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). + -- short of the specified module partial_mg | LoadDependenciesOf _mod <- how_much = assert (case last partial_mg0 of @@ -525,27 +506,7 @@ load' how_much mHscMessage mod_graph = do | otherwise = partial_mg0 - stable_mg = - [ AcyclicSCC ems - | AcyclicSCC (ModuleNode ems@(ExtendedModSummary ms _)) <- full_mg - , stable_mod_summary ms - ] - - stable_mod_summary ms = - ms_mod_name ms `elementOfUniqSet` stable_obj || - ms_mod_name ms `elementOfUniqSet` stable_bco - - -- the modules from partial_mg that are not also stable - -- NB. also keep cycles, we need to emit an error message later - unstable_mg = filter not_stable partial_mg - where not_stable (CyclicSCC _) = True - not_stable (AcyclicSCC (InstantiationNode _)) = True - not_stable (AcyclicSCC (ModuleNode (ExtendedModSummary ms _))) - = not $ stable_mod_summary ms - - -- Load all the stable modules first, before attempting to load - -- an unstable module (#7231). - mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg + mg = partial_mg liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) @@ -558,7 +519,7 @@ load' how_much mHscMessage mod_graph = do setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $ - upsweep_fn mHscMessage pruned_hpt stable_mods mg + upsweep_fn mHscMessage pruned_hpt mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -690,7 +651,7 @@ loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag loadFinish _all_ok Failed = do hsc_env <- getSession let interp = hscInterp hsc_env - liftIO $ unload interp hsc_env [] + liftIO $ unload interp hsc_env modifySession discardProg return Failed @@ -767,8 +728,7 @@ guessOutputFile = modifySession $ \env -> -- -- Before doing an upsweep, we can throw away: -- --- - For non-stable modules: --- - all ModDetails, all linked code +-- - all ModDetails, all linked code -- - all unlinked code that is out of date with respect to -- the source file -- @@ -778,16 +738,13 @@ guessOutputFile = modifySession $ \env -> -- compilation. pruneHomePackageTable :: HomePackageTable -> [ModSummary] - -> StableModules -> HomePackageTable -pruneHomePackageTable hpt summ (stable_obj, stable_bco) +pruneHomePackageTable hpt summ = mapHpt prune hpt - where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } + where prune hmi = hmi'{ hm_details = emptyModDetails } where modl = moduleName (mi_module (hm_iface hmi)) - hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + hmi' | mi_src_hash (hm_iface hmi) /= ms_hs_hash ms = hmi{ hm_linkable = Nothing } | otherwise = hmi @@ -795,9 +752,6 @@ pruneHomePackageTable hpt summ (stable_obj, stable_bco) ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] - is_stable m = - m `elementOfUniqSet` stable_obj || - m `elementOfUniqSet` stable_bco -- ----------------------------------------------------------------------------- -- @@ -820,10 +774,10 @@ findPartiallyCompletedCycles modsDone theGraph -- --------------------------------------------------------------------------- -- -- | Unloading -unload :: Interp -> HscEnv -> [Linkable] -> IO () -unload interp hsc_env stable_linkables -- Unload everything *except* 'stable_linkables' +unload :: Interp -> HscEnv -> IO () +unload interp hsc_env = case ghcLink (hsc_dflags hsc_env) of - LinkInMemory -> Linker.unload interp hsc_env stable_linkables + LinkInMemory -> Linker.unload interp hsc_env [] _other -> return () -- ----------------------------------------------------------------------------- @@ -836,7 +790,7 @@ unload interp hsc_env stable_linkables -- Unload everything *except* 'stable_lin modules near the bottom of the tree have not changed. - to tell GHCi when it can load object code: we can only load object code - for a module when we also load object code fo all of the imports of the + for a module when we also load object code for all of the imports of the module. So we need to know that we will definitely not be recompiling any of these modules, and we can use the object code. @@ -849,11 +803,12 @@ unload interp hsc_env stable_linkables -- Unload everything *except* 'stable_lin stableObject m = all stableObject (imports m) && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) + && date(on-disk .o) >= date(on-disk .hi) + && hash(on-disk .hs) == hash recorded in .hi stableBCO m = all stable (imports m) - && date(BCO) > date(.hs) + && hash(on-disk .hs) == hash recorded alongside BCO @ These properties embody the following ideas: @@ -879,75 +834,10 @@ unload interp hsc_env stable_linkables -- Unload everything *except* 'stable_lin if the interface is out of date because an *external* interface has changed. The current code in GHC.Driver.Make handles this case fairly poorly, so be careful. --} - -type StableModules = - ( UniqSet ModuleName -- stableObject - , UniqSet ModuleName -- stableBCO - ) - -checkStability - :: HomePackageTable -- HPT from last compilation - -> [SCC ModSummary] -- current module graph (cyclic) - -> UniqSet ModuleName -- all home modules - -> StableModules + See also Note [When source is considered modified] +-} -checkStability hpt sccs all_home_mods = - foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs - where - checkSCC :: StableModules -> SCC ModSummary -> StableModules - checkSCC (stable_obj, stable_bco) scc0 - | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco) - | stableBCOs = (stable_obj, addListToUniqSet stable_bco scc_mods) - | otherwise = (stable_obj, stable_bco) - where - scc = flattenSCC scc0 - scc_mods = map ms_mod_name scc - home_module m = - m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods - - scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) - -- all imports outside the current SCC, but in the home pkg - - stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps - stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps - - stableObjects = - and stable_obj_imps - && all object_ok scc - - stableBCOs = - and (zipWith (||) stable_obj_imps stable_bco_imps) - && all bco_ok scc - - object_ok ms - | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False - | Just t <- ms_obj_date ms = t >= ms_hs_date ms - && same_as_prev t - | otherwise = False - where - same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi - -> isObjectLinkable l && t == linkableTime l - _other -> True - -- why '>=' rather than '>' above? If the filesystem stores - -- times to the nearest second, we may occasionally find that - -- the object & source have the same modification time, - -- especially if the source was automatically generated - -- and compiled. Using >= is slightly unsafe, but it matches - -- make's behaviour. - -- - -- But see #5527, where someone ran into this and it caused - -- a problem. - - bco_ok ms - | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False - | otherwise = case lookupHpt hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False {- Parallel Upsweep - @@ -1006,13 +896,6 @@ buildCompGraph (scc:sccs) = case scc of data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot deriving (Eq, Ord) --- | Tests if an 'HscSource' is a boot file, primarily for constructing elements --- of 'BuildModule'. We conflate signatures and modules because they are bound --- in the same namespace; only boot interfaces can be disambiguated with --- `import {-# SOURCE #-}`. -hscSourceToIsBoot :: HscSource -> IsBootInterface -hscSourceToIsBoot HsBootFile = IsBoot -hscSourceToIsBoot _ = NotBoot mkBuildModule :: ModuleGraphNode -> BuildModule mkBuildModule = \case @@ -1045,11 +928,10 @@ parUpsweep -- ^ The number of workers we wish to run in parallel -> Maybe Messager -> HomePackageTable - -> StableModules -> [SCC ModuleGraphNode] -> m (SuccessFlag, [ModuleGraphNode]) -parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do +parUpsweep n_jobs mHscMessage old_hpt sccs = do hsc_env <- getSession let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env @@ -1174,7 +1056,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do lcl_logger lcl_tmpfs dflags (hsc_home_unit hsc_env) mHscMessage par_sem hsc_env_var old_hpt_var - stable_mods mod_idx (length sccs) + mod_idx (length sccs) res <- case m_res of Right flag -> return flag @@ -1283,8 +1165,6 @@ parUpsweep_one -- ^ The MVar that synchronizes updates to the global HscEnv -> IORef HomePackageTable -- ^ The old HPT - -> StableModules - -- ^ Sets of stable objects and BCOs -> Int -- ^ The index of this module -> Int @@ -1292,7 +1172,7 @@ parUpsweep_one -> IO SuccessFlag -- ^ The result of this compile parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags home_unit mHscMessage par_sem - hsc_env_var old_hpt_var stable_mods mod_index num_mods = do + hsc_env_var old_hpt_var mod_index num_mods = do let this_build_mod = mkBuildModule0 mod @@ -1422,7 +1302,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags map (moduleName . gwib_mod) loop -- Compile the module. - mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods + mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt mod mod_index num_mods return (Just mod_info) @@ -1476,7 +1356,6 @@ upsweep . GhcMonad m => Maybe Messager -> HomePackageTable -- ^ HPT from last time round (pruned) - -> StableModules -- ^ stable modules (see checkStability) -> [SCC ModuleGraphNode] -- ^ Mods to do (the worklist) -> m (SuccessFlag, [ModuleGraphNode]) @@ -1486,7 +1365,7 @@ upsweep -- 2. The 'HscEnv' in the monad has an updated HPT -- 3. A list of modules which succeeded loading. -upsweep mHscMessage old_hpt stable_mods sccs = do +upsweep mHscMessage old_hpt sccs = do (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) return (res, reverse $ mgModSummaries' done) where @@ -1575,7 +1454,7 @@ upsweep mHscMessage old_hpt stable_mods sccs = do mb_mod_info <- handleSourceError (\err -> do logg mod (Just err); return Nothing) $ do - mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods + mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt mod mod_index nmods logg mod Nothing -- log warnings return (Just mod_info) @@ -1618,7 +1497,7 @@ upsweep mHscMessage old_hpt stable_mods sccs = do -- table. See Note [Grand plan for static forms] in -- GHC.Iface.Tidy.StaticPtrTable. when (backend (hsc_dflags hsc_env4) == Interpreter) $ - liftIO $ hscAddSptEntries hsc_env4 + liftIO $ hscAddSptEntries hsc_env4 (Just (ms_mnwib mod)) [ spt | Just linkable <- pure $ hm_linkable mod_info , unlinked <- linkableUnlinked linkable @@ -1628,15 +1507,6 @@ upsweep mHscMessage old_hpt stable_mods sccs = do upsweep' old_hpt1 done' mods (mod_index+1) nmods -maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) -maybeGetIfaceDate dflags location - | writeInterfaceOnlyMode dflags - -- Minor optimization: it should be harmless to check the hi file location - -- always, but it's better to avoid hitting the filesystem if possible. - = modificationTimeIfExists (ml_hi_file location) - | otherwise - = return Nothing - upsweep_inst :: HscEnv -> Maybe Messager -> Int -- index of module @@ -1655,22 +1525,13 @@ upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do upsweep_mod :: HscEnv -> Maybe Messager -> HomePackageTable - -> StableModules -> ModSummary -> Int -- index of module -> Int -- total number of modules -> IO HomeModInfo -upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods +upsweep_mod hsc_env mHscMessage old_hpt summary mod_index nmods = let this_mod_name = ms_mod_name summary - this_mod = ms_mod summary - mb_obj_date = ms_obj_date summary - mb_if_date = ms_iface_date summary - obj_fn = ml_obj_file (ms_location summary) - hs_date = ms_hs_date summary - - is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj - is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco old_hmi = lookupHpt old_hpt this_mod_name @@ -1715,104 +1576,13 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind where iface = hm_iface hm_info - compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo - compile_it mb_linkable src_modified = - compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods - mb_old_iface mb_linkable src_modified - - compile_it_discard_iface :: Maybe Linkable -> SourceModified - -> IO HomeModInfo - compile_it_discard_iface mb_linkable src_modified = + compile_it :: Maybe Linkable -> IO HomeModInfo + compile_it mb_linkable = compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods - Nothing mb_linkable src_modified - - -- With NoBackend we create empty linkables to avoid recompilation. - -- We have to detect these to recompile anyway if the backend changed - -- since the last compile. - is_fake_linkable - | Just hmi <- old_hmi, Just l <- hm_linkable hmi = - null (linkableUnlinked l) - | otherwise = - -- we have no linkable, so it cannot be fake - False - - implies False _ = True - implies True x = x - - debug_trace n t = liftIO $ debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) n t + mb_old_iface mb_linkable in - case () of - _ - -- Regardless of whether we're generating object code or - -- byte code, we can always use an existing object file - -- if it is *stable* (see checkStability). - | is_stable_obj, Just hmi <- old_hmi -> do - debug_trace 5 (text "skipping stable obj mod:" <+> ppr this_mod_name) - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - debug_trace 5 (text "compiling stable on-disk mod:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) SourceUnmodifiedAndStable - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - | not (backendProducesObject bcknd), is_stable_bco, - (bcknd /= NoBackend) `implies` not is_fake_linkable -> - assert (isJust old_hmi) $ -- must be in the old_hpt - let Just hmi = old_hmi in do - debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name) - return hmi - -- BCO is stable: nothing to do - - | not (backendProducesObject bcknd), - Just hmi <- old_hmi, - Just l <- hm_linkable hmi, - not (isObjectLinkable l), - (bcknd /= NoBackend) `implies` not is_fake_linkable, - linkableTime l >= ms_hs_date summary -> do - debug_trace 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) - compile_it (Just l) SourceUnmodified - -- we have an old BCO that is up to date with respect - -- to the source: do a recompilation check as normal. - - -- When generating object code, if there's an up-to-date - -- object file on the disk, then we can use it. - -- However, if the object file is new (compared to any - -- linkable we had from a previous compilation), then we - -- must discard any in-memory interface, because this - -- means the user has compiled the source file - -- separately and generated a new interface, that we must - -- read from the disk. - -- - | backendProducesObject bcknd, - Just obj_date <- mb_obj_date, - obj_date >= hs_date -> do - case old_hmi of - Just hmi - | Just l <- hm_linkable hmi, - isObjectLinkable l && linkableTime l == obj_date -> do - debug_trace 5 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) - compile_it (Just l) SourceUnmodified - _otherwise -> do - debug_trace 5 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date - compile_it_discard_iface (Just linkable) SourceUnmodified - - -- See Note [Recompilation checking in -fno-code mode] - | writeInterfaceOnlyMode lcl_dflags, - Just if_date <- mb_if_date, - if_date >= hs_date -> do - debug_trace 5 (text "skipping tc'd mod:" <+> ppr this_mod_name) - compile_it Nothing SourceUnmodified - - _otherwise -> do - debug_trace 5 (text "compiling mod:" <+> ppr this_mod_name) - compile_it Nothing SourceModified + compile_it (old_hmi >>= hm_linkable) {- Note [-fno-code mode] @@ -1878,13 +1648,53 @@ Potential TODOS: generating temporary ones. -} --- Note [Recompilation checking in -fno-code mode] +-- Note [When source is considered modified] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- If we are compiling with -fno-code -fwrite-interface, there won't --- be any object code that we can compare against, nor should there --- be: we're *just* generating interface files. In this case, we --- want to check if the interface file is new, in lieu of the object --- file. See also #9243. +-- A number of functions in GHC.Driver accept a SourceModified argument, which +-- is part of how GHC determines whether recompilation may be avoided (see the +-- definition of the SourceModified data type for details). +-- +-- Determining whether or not a source file is considered modified depends not +-- only on the source file itself, but also on the output files which compiling +-- that module would produce. This is done because GHC supports a number of +-- flags which control which output files should be produced, e.g. -fno-code +-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the +-- source file has been modified since the last compile, but also whether the +-- source file has been modified since the last compile which produced all of +-- the output files which have been requested. +-- +-- Specifically, a source file is considered unmodified if it is up-to-date +-- relative to all of the output files which have been requested. Whether or +-- not an output file is up-to-date depends on what kind of file it is: +-- +-- * iface (.hi) files are considered up-to-date if (and only if) their +-- mi_src_hash field matches the hash of the source file, +-- +-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date +-- if (and only if) their modification times on the filesystem are greater +-- than or equal to the modification time of the corresponding .hi file. +-- +-- Why do we use '>=' rather than '>' for output files other than the .hi file? +-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a +-- resolution of 2 seconds), we may often find that the .hi and .o files have +-- the same modification time. Using >= is slightly unsafe, but it matches +-- make's behaviour. +-- +-- This strategy allows us to do the minimum work necessary in order to ensure +-- that all the files the user cares about are up-to-date; e.g. we should not +-- worry about .o files if the user has indicated that they are not interested +-- in them via -fno-code. See also #9243. +-- +-- Note that recompilation avoidance is dependent on .hi files being produced, +-- which does not happen if -fno-write-interface -fno-code is passed. That is, +-- passing -fno-write-interface -fno-code means that you cannot benefit from +-- recompilation avoidance. See also Note [-fno-code mode]. +-- +-- The correctness of this strategy depends on an assumption that whenever we +-- are producing multiple output files, the .hi file is always written first. +-- If this assumption is violated, we risk recompiling unnecessarily by +-- incorrectly regarding non-.hi files as outdated. +-- -- Filter modules in the HPT retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable @@ -2262,21 +2072,19 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots getRootSummary :: Target -> IO (Either DriverMessages ExtendedModSummary) getRootSummary Target { targetId = TargetFile file mb_phase - , targetAllowObjCode = obj_allowed , targetContents = maybe_buf } = do exists <- liftIO $ doesFileExist file if exists || isJust maybe_buf then summariseFile hsc_env old_summaries file mb_phase - obj_allowed maybe_buf + maybe_buf else return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound file) getRootSummary Target { targetId = TargetModule modl - , targetAllowObjCode = obj_allowed , targetContents = maybe_buf } = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot - (L rootLoc modl) obj_allowed + (L rootLoc modl) maybe_buf excl_mods case maybe_summary of Nothing -> return $ Left $ moduleNotFoundErr modl @@ -2320,7 +2128,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots } | otherwise = do mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod True + is_boot wanted_mod Nothing excl_mods case mb_s of Nothing -> loop ss done @@ -2490,40 +2298,39 @@ summariseFile -> [ExtendedModSummary] -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase - -> Bool -- object code allowed? -> Maybe (StringBuffer,UTCTime) -> IO (Either DriverMessages ExtendedModSummary) -summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf +summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, But we have to look up the summary -- by source file, rather than module name as we do in summarise. | Just old_summary <- findSummaryBySourceFile old_summaries src_fn = do let location = ms_location $ emsModSummary old_summary - dflags = hsc_dflags hsc_env - src_timestamp <- get_src_timestamp + src_hash <- get_src_hash -- The file exists; we checked in getRootSummary above. -- If it gets removed subsequently, then this - -- getModificationUTCTime may fail, but that's the right + -- getFileHash may fail, but that's the right -- behaviour. -- return the cached summary if the source didn't change - checkSummaryTimestamp - hsc_env dflags obj_allowed NotBoot (new_summary src_fn) - old_summary location src_timestamp + checkSummaryHash + hsc_env (new_summary src_fn) + old_summary location src_hash | otherwise - = do src_timestamp <- get_src_timestamp - new_summary src_fn src_timestamp + = do src_hash <- get_src_hash + new_summary src_fn src_hash where - get_src_timestamp = case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime src_fn - -- getModificationUTCTime may fail + -- src_fn does not necessarily exist on the filesystem, so we need to + -- check what kind of target we are dealing with + get_src_hash = case maybe_buf of + Just (buf,_) -> return $ fingerprintStringBuffer buf + Nothing -> liftIO $ getFileHash src_fn - new_summary src_fn src_timestamp = runExceptT $ do + new_summary src_fn src_hash = runExceptT $ do preimps@PreprocessedImports {..} <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf @@ -2540,7 +2347,7 @@ summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary { nms_src_fn = src_fn - , nms_src_timestamp = src_timestamp + , nms_src_hash = src_hash , nms_is_boot = NotBoot , nms_hsc_src = if isHaskellSigFilename src_fn @@ -2548,7 +2355,6 @@ summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf else HsSrcFile , nms_location = location , nms_mod = mod - , nms_obj_allowed = obj_allowed , nms_preimps = preimps } @@ -2564,23 +2370,19 @@ findSummaryBySourceFile summaries file = case [] -> Nothing (x:_) -> Just x -checkSummaryTimestamp - :: HscEnv -> DynFlags -> Bool -> IsBootInterface - -> (UTCTime -> IO (Either e ExtendedModSummary)) - -> ExtendedModSummary -> ModLocation -> UTCTime +checkSummaryHash + :: HscEnv + -> (Fingerprint -> IO (Either e ExtendedModSummary)) + -> ExtendedModSummary -> ModLocation -> Fingerprint -> IO (Either e ExtendedModSummary) -checkSummaryTimestamp - hsc_env dflags obj_allowed is_boot new_summary +checkSummaryHash + hsc_env new_summary (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps}) - location src_timestamp - | ms_hs_date old_summary == src_timestamp && + location src_hash + | ms_hs_hash old_summary == src_hash && not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do -- update the object-file timestamp - obj_timestamp <- - if backendProducesObject (backend (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location is_boot - else return Nothing + obj_timestamp <- modificationTimeIfExists (ml_obj_file location) -- We have to repopulate the Finder's cache for file targets -- because the file might not even be on the regular search path @@ -2593,7 +2395,7 @@ checkSummaryTimestamp addHomeModuleToFinder fc home_unit (moduleName (ms_mod old_summary)) location - hi_timestamp <- maybeGetIfaceDate dflags location + hi_timestamp <- modificationTimeIfExists (ml_hi_file location) hie_timestamp <- modificationTimeIfExists (ml_hie_file location) return $ Right @@ -2608,7 +2410,7 @@ checkSummaryTimestamp | otherwise = -- source changed: re-summarise. - new_summary src_timestamp + new_summary src_hash -- Summarise a module, and pick up source and timestamp. summariseModule @@ -2617,13 +2419,12 @@ summariseModule -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised - -> Bool -- object code allowed? -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude -> IO (Maybe (Either DriverMessages ExtendedModSummary)) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) - obj_allowed maybe_buf excl_mods + maybe_buf excl_mods | wanted_mod `elem` excl_mods = return Nothing @@ -2635,19 +2436,17 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) let location = ms_location $ emsModSummary old_summary src_fn = expectJust "summariseModule" (ml_hs_file location) - -- check the modification time on the source file, and + -- check the hash on the source file, and -- return the cached summary if it hasn't changed. If the -- file has disappeared, we need to call the Finder again. case maybe_buf of - Just (_,t) -> - Just <$> check_timestamp old_summary location src_fn t + Just (buf,_) -> + Just <$> check_hash old_summary location src_fn (fingerprintStringBuffer buf) Nothing -> do - m <- tryIO (getModificationUTCTime src_fn) - case m of - Right t -> - Just <$> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e + mb_hash <- fileHashIfExists src_fn + case mb_hash of + Just hash -> Just <$> check_hash old_summary location src_fn hash + Nothing -> find_it | otherwise = find_it where @@ -2656,9 +2455,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) fc = hsc_FC hsc_env units = hsc_units hsc_env - check_timestamp old_summary location src_fn = - checkSummaryTimestamp - hsc_env dflags obj_allowed is_boot + check_hash old_summary location src_fn = + checkSummaryHash + hsc_env (new_summary location (ms_mod $ emsModSummary old_summary) src_fn) old_summary location @@ -2685,12 +2484,12 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- Check that it exists -- It might have been deleted since the Finder last found it - maybe_t <- modificationTimeIfExists src_fn - case maybe_t of + maybe_h <- fileHashIfExists src_fn + case maybe_h of Nothing -> return $ Left $ noHsFileErr loc src_fn - Just t -> new_summary location' mod src_fn t + Just h -> new_summary location' mod src_fn h - new_summary location mod src_fn src_timestamp + new_summary location mod src_fn src_hash = runExceptT $ do preimps@PreprocessedImports {..} <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf @@ -2718,12 +2517,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary { nms_src_fn = src_fn - , nms_src_timestamp = src_timestamp + , nms_src_hash = src_hash , nms_is_boot = is_boot , nms_hsc_src = hsc_src , nms_location = location , nms_mod = mod - , nms_obj_allowed = obj_allowed , nms_preimps = preimps } @@ -2732,12 +2530,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) data MakeNewModSummary = MakeNewModSummary { nms_src_fn :: FilePath - , nms_src_timestamp :: UTCTime + , nms_src_hash :: Fingerprint , nms_is_boot :: IsBootInterface , nms_hsc_src :: HscSource , nms_location :: ModLocation , nms_mod :: Module - , nms_obj_allowed :: Bool , nms_preimps :: PreprocessedImports } @@ -2745,16 +2542,9 @@ makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary makeNewModSummary hsc_env MakeNewModSummary{..} = do let PreprocessedImports{..} = nms_preimps let dflags = hsc_dflags hsc_env - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- liftIO $ - if backendProducesObject (backend dflags) - || nms_obj_allowed -- bug #1205 - then getObjTimestamp nms_location nms_is_boot - else return Nothing - - hi_timestamp <- maybeGetIfaceDate dflags nms_location + obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) + dyn_obj_timestamp <- modificationTimeIfExists (dynamicOutputFile dflags (ml_obj_file nms_location)) + hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location) hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name @@ -2775,20 +2565,15 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do pi_theimps ++ extra_sig_imports ++ ((,) Nothing . noLoc <$> implicit_sigs) - , ms_hs_date = nms_src_timestamp + , ms_hs_hash = nms_src_hash , ms_iface_date = hi_timestamp , ms_hie_date = hie_timestamp , ms_obj_date = obj_timestamp + , ms_dyn_obj_date = dyn_obj_timestamp } , emsInstantiatedUnits = inst_deps } -getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime) -getObjTimestamp location is_boot - = case is_boot of - IsBoot -> return Nothing - NotBoot -> modificationTimeIfExists (ml_obj_file location) - data PreprocessedImports = PreprocessedImports { pi_local_dflags :: DynFlags diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 307499887d..44ae426e2d 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -42,6 +42,7 @@ import GHC.Prelude import GHC.Platform import GHC.Tc.Types +import GHC.Tc.Utils.Monad hiding ( getImports ) import GHC.Driver.Main import GHC.Driver.Env hiding ( Hsc ) @@ -74,7 +75,6 @@ import GHC.Utils.Fingerprint import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Utils.Monad import GHC.Utils.Exception as Exception import GHC.Utils.Logger @@ -89,6 +89,7 @@ import GHC.Data.Maybe ( expectJust ) import GHC.Iface.Make ( mkFullIface ) import GHC.Runtime.Loader ( initializePlugins ) + import GHC.Types.Basic ( SuccessFlag(..) ) import GHC.Types.Error ( singleMessage, getMessages ) import GHC.Types.Name.Env @@ -118,7 +119,7 @@ import Data.Maybe import Data.Version import Data.Either ( partitionEithers ) -import Data.Time ( UTCTime ) +import Data.Time ( getCurrentTime ) -- --------------------------------------------------------------------------- -- Pre-process @@ -188,7 +189,6 @@ compileOne :: HscEnv -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one - -> SourceModified -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compileOne = compileOne' Nothing (Just batchMsg) @@ -201,12 +201,10 @@ compileOne' :: Maybe TcGblEnv -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one - -> SourceModified -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compileOne' m_tc_result mHscMessage hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable - source_modified0 = do debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp) @@ -219,8 +217,7 @@ compileOne' m_tc_result mHscMessage addFilesToClean tmpfs TFL_GhcSession $ [ml_obj_file $ ms_location summary] - plugin_hsc_env <- initializePlugins hsc_env - + plugin_hsc_env <- initializePlugins hsc_env (Just (ms_mnwib summary)) let runPostTc = compileOnePostTc plugin_hsc_env summary case m_tc_result of @@ -229,14 +226,14 @@ compileOne' m_tc_result mHscMessage runPostTc (FrontendTypecheck tc_result) emptyMessages Nothing _ -> do status <- hscRecompStatus mHscMessage plugin_hsc_env summary - source_modified mb_old_iface (mod_index, nmods) + mb_old_iface mb_old_linkable (mod_index, nmods) case status of - HscUpToDate iface -> do - massert ( isJust mb_old_linkable || isNoLink (ghcLink dflags) ) + HscUpToDate iface old_linkable -> do + massert ( isJust old_linkable || isNoLink (ghcLink dflags) ) -- See Note [ModDetails and --make mode] details <- initModDetails plugin_hsc_env summary iface - return $! HomeModInfo iface details mb_old_linkable + return $! HomeModInfo iface details old_linkable HscRecompNeeded mb_old_hash -> do (tc_result, warnings) <- hscTypecheckAndGetWarnings plugin_hsc_env summary runPostTc tc_result warnings mb_old_hash @@ -288,21 +285,12 @@ compileOne' m_tc_result mHscMessage -- was set), force it to generate byte-code. This is NOT transitive and -- only applies to direct targets. | loadAsByteCode - = (Interpreter, dflags2 { backend = Interpreter }) + = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp) | otherwise = (backend dflags, dflags2) dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] } hsc_env = hsc_env0 {hsc_dflags = dflags} - -- -fforce-recomp should also work with --make - force_recomp = gopt Opt_ForceRecomp dflags - source_modified - -- #8042: Usually pre-compiled code is preferred to be loaded in ghci - -- if available. So, if the "*" prefix was used, force recompilation - -- to make sure byte-code is loaded. - | force_recomp || loadAsByteCode = SourceModified - | otherwise = source_modified0 - always_do_basic_recompilation_check = case bcknd of Interpreter -> True _ -> False @@ -540,7 +528,7 @@ link' logger tmpfs dflags unit_env batch_attempt_linking hpt return Succeeded else do - let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked) obj_files = concatMap getOfiles linkables platform = targetPlatform dflags exe_file = exeFileName platform staticLink (outputFile dflags) @@ -1225,9 +1213,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do runPhase (RealPhase (Hsc src_flavour)) input_fn = do -- normal Hsc mode, not mkdependHS dflags0 <- getDynFlags - - PipeEnv{ stop_phase=stop, - src_basename=basename, + PipeEnv{ src_basename=basename, src_suffix=suff } <- getPipeEnv -- we add the current directory (i.e. the directory in which @@ -1257,48 +1243,16 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn -- the object file for one module.) -- Note the nasty duplication with the same computation in compileFile above location <- getLocation src_flavour mod_name - dt_state <- dynamicTooState dflags let o_file = ml_obj_file location -- The real object file - -- dynamic-too *also* produces the dyn_o_file, so have to check - -- that's there, and if it's not, regenerate both .o and - -- .dyn_o - dyn_o_file = case dt_state of - DT_OK - | not (writeInterfaceOnlyMode dflags) - -> Just (dynamicOutputFile dflags o_file) - _ -> Nothing hi_file = ml_hi_file location hie_file = ml_hie_file location - dest_file | writeInterfaceOnlyMode dflags - = hi_file - | otherwise - = o_file - - -- Figure out if the source has changed, for recompilation avoidance. - -- - -- Setting source_unchanged to True means that M.o, M.dyn_o (or M.hie) seems - -- to be up to date wrt M.hs; so no need to recompile unless imports have - -- changed (which the compiler itself figures out). - -- Setting source_unchanged to False tells the compiler that M.o or M.dyn_o is out of - -- date wrt M.hs (or M.o/dyn_o doesn't exist) so we must recompile regardless. - src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff) - - source_unchanged <- liftIO $ - if not (isStopLn stop) - -- SourceModified unconditionally if - -- (a) recompilation checker is off, or - -- (b) we aren't going all the way to .o file (e.g. ghc -S) - then return SourceModified - -- Otherwise look at file modification dates - else do dest_file_mod <- sourceModified dest_file src_timestamp - dyn_file_mod <- traverse (flip sourceModified src_timestamp) dyn_o_file - hie_file_mod <- if gopt Opt_WriteHie dflags - then sourceModified hie_file - src_timestamp - else pure False - if dest_file_mod || hie_file_mod || fromMaybe False dyn_file_mod - then return SourceModified - else return SourceUnmodified + dyn_o_file = dynamicOutputFile dflags o_file + + src_hash <- liftIO $ getFileHash (basename <.> suff) + hi_date <- liftIO $ modificationTimeIfExists hi_file + hie_date <- liftIO $ modificationTimeIfExists hie_file + o_mod <- liftIO $ modificationTimeIfExists o_file + dyn_o_mod <- liftIO $ modificationTimeIfExists dyn_o_file PipeState{hsc_env=hsc_env'} <- getPipeState @@ -1316,17 +1270,19 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn ms_hspp_opts = dflags, ms_hspp_buf = hspp_buf, ms_location = location, - ms_hs_date = src_timestamp, - ms_obj_date = Nothing, + ms_hs_hash = src_hash, + ms_obj_date = o_mod, + ms_dyn_obj_date = dyn_o_mod, ms_parsed_mod = Nothing, - ms_iface_date = Nothing, - ms_hie_date = Nothing, + ms_iface_date = hi_date, + ms_hie_date = hie_date, ms_textual_imps = imps, ms_srcimps = src_imps } + -- run the compiler! let msg hsc_env _ what _ = oneShotMsg hsc_env what - plugin_hsc_env' <- liftIO $ initializePlugins hsc_env' + plugin_hsc_env' <- liftIO $ initializePlugins hsc_env' (Just $ ms_mnwib mod_summary) -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. @@ -1335,11 +1291,11 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_var = Just (mod, type_env_var) } status <- liftIO $ hscRecompStatus (Just msg) plugin_hsc_env mod_summary - source_unchanged Nothing (1, 1) + Nothing Nothing (1, 1) logger <- getLogger case status of - HscUpToDate iface -> + HscUpToDate iface _ -> do liftIO $ touchObjectFile logger dflags o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't get Nothing) @@ -1369,14 +1325,9 @@ runPhase (HscPostTc mod_summary tc_result tc_warnings mb_old_hash) _ = do next_phase <- case hscBackendAction of HscUpdate iface -> do setIface iface - -- Need to set a fake linkable - let setLinkableAndStop = do - unless (isHsBootOrSig $ ms_hsc_src mod_summary) $ - setLinkable (LM (ms_hs_date mod_summary) (ms_mod mod_summary) []) - return $ RealPhase StopLn case backend dflags of - NoBackend -> setLinkableAndStop - Interpreter -> setLinkableAndStop + NoBackend -> return $ RealPhase StopLn + Interpreter -> return $ RealPhase StopLn _ -> return hscBackendPhase -- Need to create .o, and handle -dynamic-too _ -> return hscBackendPhase @@ -1437,7 +1388,7 @@ runPhase (HscBackend mod_summary result) _ = do return [DotO stub_o] let hs_unlinked = [BCOs comp_bc spt_entries] - unlinked_time = ms_hs_date mod_summary + unlinked_time <- liftIO getCurrentTime -- Why do we use the timestamp of the source file here, -- rather than the current time? This works better in -- the case where the local clock is out of sync @@ -2163,22 +2114,6 @@ joinObjectFiles logger tmpfs dflags o_files output_fn = do -- ----------------------------------------------------------------------------- -- Misc. -writeInterfaceOnlyMode :: DynFlags -> Bool -writeInterfaceOnlyMode dflags = - gopt Opt_WriteInterface dflags && - NoBackend == backend dflags - --- | Figure out if a source file was modified after an output file (or if we --- anyways need to consider the source file modified since the output is gone). -sourceModified :: FilePath -- ^ destination file we are looking for - -> UTCTime -- ^ last time of modification of source file - -> IO Bool -- ^ do we need to regenerate the output? -sourceModified dest_file src_timestamp = do - dest_file_exists <- doesFileExist dest_file - if not dest_file_exists - then return True -- Need to recompile - else do t2 <- getModificationUTCTime dest_file - return (t2 <= src_timestamp) -- | What phase to run after one of the backend code generators has run hscPostBackendPhase :: HscSource -> Backend -> Phase diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index f2238aeffb..409d0ff6d3 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -203,8 +203,9 @@ deSugar hsc_env ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files ; safe_mode <- finalSafeMode dflags tcg_env - ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names - dep_files merged pluginModules + + ; usages <- mkUsageInfo hsc_env mod hsc_src (imp_mods imports) used_names + dep_files merged -- id_mod /= mod when we are processing an hsig, but hsigs -- never desugared and compiled (there's no code!) -- Consequently, this should hold for any ModGuts that make diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index 0da8f59070..4731d32591 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -12,8 +12,6 @@ import GHC.Prelude import GHC.Driver.Env import GHC.Driver.Session -import GHC.Platform -import GHC.Platform.Ways import GHC.Tc.Types @@ -23,29 +21,26 @@ import GHC.Utils.Fingerprint import GHC.Utils.Panic import GHC.Types.Name -import GHC.Types.Name.Set +import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Unit import GHC.Unit.External -import GHC.Unit.State -import GHC.Unit.Finder import GHC.Unit.Module.Imported import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps import GHC.Data.Maybe -import Control.Monad (filterM) -import Data.List (sortBy, sort, nub) -import Data.IORef +import Data.List (sortBy, sort, partition) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set -import System.Directory -import System.FilePath +import GHC.Linker.Types +import GHC.Linker.Loader ( getLoaderState ) +import GHC.Types.SourceFile {- Note [Module self-dependency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -73,15 +68,15 @@ its dep_orphs. This was the cause of #14128. mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies mkDependencies iuid pluginModules (TcGblEnv{ tcg_mod = mod, - tcg_imports = imports, - tcg_th_used = th_var + tcg_imports = imports }) = do - -- Template Haskell used? - let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ] - plugin_dep_pkgs = filter (/= iuid) (map (toUnitId . moduleUnit) ms) - th_used <- readIORef th_var - let direct_mods = modDepsElts (delFromUFM (imp_direct_dep_mods imports) (moduleName mod)) + + let (home_plugins, package_plugins) = partition ((== iuid) . toUnitId . moduleUnit) pluginModules + plugin_dep_pkgs = map (toUnitId . moduleUnit) package_plugins + all_direct_mods = foldr (\mn m -> addToUFM m mn (GWIB mn NotBoot)) (imp_direct_dep_mods imports) (map moduleName home_plugins) + + direct_mods = modDepsElts (delFromUFM all_direct_mods (moduleName mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove -- it before recording the modules on which this one depends! -- (We want to retain M.hi-boot in imp_dep_mods so that @@ -95,9 +90,7 @@ mkDependencies iuid pluginModules direct_pkgs_0 = foldr Set.insert (imp_dep_direct_pkgs imports) plugin_dep_pkgs - direct_pkgs - | th_used = Set.insert thUnitId direct_pkgs_0 - | otherwise = direct_pkgs_0 + direct_pkgs = direct_pkgs_0 -- Set the packages required to be Safe according to Safe Haskell. -- See Note [Tracking Trust Transitively] in GHC.Rename.Names @@ -116,7 +109,6 @@ mkDependencies iuid pluginModules dep_trusted_pkgs = sort (Set.toList trust_pkgs), dep_boot_mods = sort source_mods, dep_orphs = dep_orphs, - dep_plgins = dep_plgins, dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } -- sort to get into canonical order -- NB. remember to use lexicographic ordering @@ -124,25 +116,26 @@ mkDependencies iuid pluginModules mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus -mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] - -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage] -mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged - pluginModules +mkUsageInfo :: HscEnv -> Module -> HscSource -> ImportedMods -> NameSet -> [FilePath] + -> [(Module, Fingerprint)] -> IO [Usage] +mkUsageInfo hsc_env this_mod src dir_imp_mods used_names dependent_files merged = do eps <- hscEPS hsc_env hashes <- mapM getFileHash dependent_files - plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules + -- Dependencies on object files due to TH and plugins + object_usages <- mkObjectUsage (eps_PIT eps) hsc_env (GWIB (moduleName this_mod) (hscSourceToIsBoot src)) let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod dir_imp_mods used_names usages = mod_usages ++ [ UsageFile { usg_file_path = f - , usg_file_hash = hash } + , usg_file_hash = hash + , usg_file_label = Nothing } | (f, hash) <- zip dependent_files hashes ] ++ [ UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } | (mod, hash) <- merged ] - ++ concat plugin_usages + ++ object_usages usages `seqList` return usages -- seq the list of Usages returned: occasionally these -- don't get evaluated for a while and we can end up hanging on to @@ -185,85 +178,47 @@ One way to improve this is to either: compare implementation hashes for recompilation. Creation of implementation hashes is however potentially expensive. -} -mkPluginUsage :: HscEnv -> ModIface -> IO [Usage] -mkPluginUsage hsc_env pluginModule - = case lookupPluginModuleWithSuggestions pkgs pNm Nothing of - LookupFound _ pkg -> do - -- The plugin is from an external package: - -- search for the library files containing the plugin. - let searchPaths = collectLibraryDirs (ways dflags) [pkg] - useDyn = WayDyn `elem` ways dflags - suffix = if useDyn then platformSOExt platform else "a" - libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix - | searchPath <- searchPaths - , libLoc <- unitHsLibs (ghcNameVersion dflags) (ways dflags) pkg - ] - -- we also try to find plugin library files by adding WayDyn way, - -- if it isn't already present (see trac #15492) - paths = - if useDyn - then libLocs - else - let dflags' = dflags { targetWays_ = addWay WayDyn (targetWays_ dflags) } - dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc - | searchPath <- searchPaths - , dlibLoc <- unitHsLibs (ghcNameVersion dflags') (ways dflags') pkg - ] - in libLocs ++ dlibLocs - files <- filterM doesFileExist paths - case files of - [] -> - pprPanic - ( "mkPluginUsage: missing plugin library, tried:\n" - ++ unlines paths - ) - (ppr pNm) - _ -> mapM hashFile (nub files) - _ -> do - let fc = hsc_FC hsc_env - let units = hsc_units hsc_env - let home_unit = hsc_home_unit hsc_env - let dflags = hsc_dflags hsc_env - foundM <- findPluginModule fc units home_unit dflags pNm - case foundM of - -- The plugin was built locally: look up the object file containing - -- the `plugin` binder, and all object files belong to modules that are - -- transitive dependencies of the plugin that belong to the same package. - Found ml _ -> do - pluginObject <- hashFile (ml_obj_file ml) - depObjects <- catMaybes <$> mapM lookupObjectFile deps - return (nub (pluginObject : depObjects)) - _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm) + +-- | Find object files corresponding to the transitive closure of given home +-- modules and direct object files for pkg dependencies +mkObjectUsage :: PackageIfaceTable -> HscEnv -> ModuleNameWithIsBoot -> IO [Usage] +mkObjectUsage pit hsc_env mnwib = do + case hsc_interp hsc_env of + Just interp -> do + mps <- getLoaderState interp + case mps of + Just ps -> do + let ls = fromMaybe [] $ Map.lookup mnwib (module_deps ps) + ds = hs_objs_loaded ps + concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds) + Nothing -> return [] + Nothing -> return [] + + where - dflags = hsc_dflags hsc_env - fc = hsc_FC hsc_env - home_unit = hsc_home_unit hsc_env - units = hsc_units hsc_env - platform = targetPlatform dflags - pkgs = hsc_units hsc_env - pNm = moduleName $ mi_module pluginModule - pPkg = moduleUnit $ mi_module pluginModule - deps = map gwib_mod $ - dep_direct_mods $ mi_deps pluginModule - - -- Lookup object file for a plugin dependency, - -- from the same package as the plugin. - lookupObjectFile nm = do - foundM <- findImportedModule fc units home_unit dflags nm Nothing - case foundM of - Found ml m - | moduleUnit m == pPkg -> Just <$> hashFile (ml_obj_file ml) - | otherwise -> return Nothing - _ -> pprPanic "mkPluginUsage: no object for dependency" - (ppr pNm <+> ppr nm) - - hashFile f = do - fExist <- doesFileExist f - if fExist - then do - h <- getFileHash f - return (UsageFile f h) - else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f) + linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls + + msg m = moduleNameString (moduleName m) ++ "[TH] changed" + + fing mmsg fn = UsageFile fn <$> getFileHash fn <*> pure mmsg + + unlinkedToUsage m ul = + case nameOfObject_maybe ul of + Just fn -> fing (Just (msg m)) fn + Nothing -> do + -- This should only happen for home package things but oneshot puts + -- home package ifaces in the PIT. + let miface = lookupIfaceByModule (hsc_HPT hsc_env) pit m + case miface of + Nothing -> pprPanic "mkObjectUsage" (ppr m) + Just iface -> + return $ UsageHomeModuleInterface (moduleName m) (mi_iface_hash (mi_final_exts iface)) + + librarySpecToUsage :: LibrarySpec -> IO [Usage] + librarySpecToUsage (Objects os) = traverse (fing Nothing) os + librarySpecToUsage (Archive fn) = traverse (fing Nothing) [fn] + librarySpecToUsage (DLLPath fn) = traverse (fing Nothing) [fn] + librarySpecToUsage _ = return [] mk_mod_usage_info :: PackageIfaceTable -> HscEnv diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index b248158ef8..8e6fb6f5b7 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -13,6 +13,7 @@ module GHC.Iface.Binary ( -- * Public API for interface file serialisation writeBinIface, readBinIface, + readBinIfaceHeader, getSymtabName, getDictFastString, CheckHiWay(..), @@ -49,6 +50,7 @@ import GHC.Types.SrcLoc import GHC.Platform import GHC.Data.FastString import GHC.Settings.Constants +import GHC.Utils.Fingerprint import Data.Array import Data.Array.IO @@ -69,15 +71,17 @@ data TraceBinIFace = TraceBinIFace (SDoc -> IO ()) | QuietBinIFace --- | Read an interface file. -readBinIface +-- | Read an interface file header, checking the magic number, version, and +-- way. Returns the hash of the source file and a BinHandle which points at the +-- start of the rest of the interface file data. +readBinIfaceHeader :: Profile -> NameCache -> CheckHiWay -> TraceBinIFace -> FilePath - -> IO ModIface -readBinIface profile name_cache checkHiWay traceBinIFace hi_path = do + -> IO (Fingerprint, BinHandle) +readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do let platform = profilePlatform profile wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () @@ -118,6 +122,20 @@ readBinIface profile name_cache checkHiWay traceBinIFace hi_path = do when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file profile tag" tag check_tag + src_hash <- get bh + pure (src_hash, bh) + +-- | Read an interface file. +readBinIface + :: Profile + -> NameCache + -> CheckHiWay + -> TraceBinIFace + -> FilePath + -> IO ModIface +readBinIface profile name_cache checkHiWay traceBinIface hi_path = do + (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path + extFields_p <- get bh mod_iface <- getWithUserData name_cache bh @@ -125,8 +143,10 @@ readBinIface profile name_cache checkHiWay traceBinIFace hi_path = do seekBin bh extFields_p extFields <- get bh - return mod_iface{mi_ext_fields = extFields} - + return mod_iface + { mi_ext_fields = extFields + , mi_src_hash = src_hash + } -- | This performs a get action after reading the dictionary and symbol -- table. It is necessary to run this before trying to deserialise any @@ -166,10 +186,11 @@ writeBinIface profile traceBinIface hi_path mod_iface = do let platform = profilePlatform profile put_ bh (binaryInterfaceMagic platform) - -- The version and profile tag go next + -- The version, profile tag, and source hash go next put_ bh (show hiVersion) let tag = profileBuildTag profile put_ bh tag + put_ bh (mi_src_hash mod_iface) extFields_p_p <- tellBin bh put_ bh extFields_p_p diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 89480c6112..2afba91a6c 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -1107,6 +1107,7 @@ pprModIface unit_state iface@ModIface{ mi_final_exts = exts } , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts)) , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts)) , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts)) + , nest 2 (text "src_hash:" <+> ppr (mi_src_hash iface)) , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) , nest 2 (text "where") @@ -1168,6 +1169,8 @@ pprUsage usage@UsageFile{} ppr (usg_file_hash usage)] pprUsage usage@UsageMergedRequirement{} = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] +pprUsage usage@UsageHomeModuleInterface{} + = hsep [text "implementation", ppr (usg_mod_name usage), ppr (usg_iface_hash usage)] pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod' @@ -1185,14 +1188,13 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods , dep_direct_pkgs = pkgs , dep_trusted_pkgs = tps , dep_finsts = finsts - , dep_plgins = plugins }) + }) = pprWithUnitState unit_state $ vcat [text "direct module dependencies:" <+> fsep (map ppr_mod dmods), text "boot module dependencies:" <+> fsep (map ppr bmods), text "direct package dependencies:" <+> fsep (map ppr_pkg pkgs), if null tps then empty else text "trusted package dependencies:" <+> fsep (map ppr_pkg pkgs), text "orphans:" <+> fsep (map ppr orphs), - text "plugins:" <+> fsep (map ppr plugins), text "family instance modules:" <+> fsep (map ppr finsts) ] where diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 416cd56d9e..86ff68272d 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -89,6 +89,7 @@ import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Deps import Data.Function @@ -96,6 +97,7 @@ import Data.List ( findIndex, mapAccumL, sortBy ) import Data.Ord import Data.IORef + {- ************************************************************************ * * @@ -106,9 +108,10 @@ import Data.IORef mkPartialIface :: HscEnv -> ModDetails + -> ModSummary -> ModGuts -> PartialModIface -mkPartialIface hsc_env mod_details +mkPartialIface hsc_env mod_details mod_summary ModGuts{ mg_module = this_mod , mg_hsc_src = hsc_src , mg_usages = usages @@ -125,7 +128,7 @@ mkPartialIface hsc_env mod_details , mg_arg_docs = arg_docs } = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust - safe_mode usages doc_hdr decl_docs arg_docs mod_details + safe_mode usages doc_hdr decl_docs arg_docs mod_summary mod_details -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information. @@ -177,9 +180,10 @@ updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf mkIfaceTc :: HscEnv -> SafeHaskellMode -- The safe haskell mode -> ModDetails -- gotten from mkBootModDetails, probably + -> ModSummary -> TcGblEnv -- Usages, deprecations, etc -> IO ModIface -mkIfaceTc hsc_env safe_mode mod_details +mkIfaceTc hsc_env safe_mode mod_details mod_summary tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, tcg_imports = imports, @@ -196,7 +200,8 @@ mkIfaceTc hsc_env safe_mode mod_details let pluginModules = map lpModule (hsc_plugins hsc_env) let home_unit = hsc_home_unit hsc_env deps <- mkDependencies (homeUnitId home_unit) - (map mi_module pluginModules) tc_result + (map mi_module pluginModules) + tc_result let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used dep_files <- (readIORef dependent_files) @@ -207,8 +212,8 @@ mkIfaceTc hsc_env safe_mode mod_details -- but if you pass that in here, we'll decide it's the local -- module and does not need to be recorded as a dependency. -- See Note [Identity versus semantic module] - usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names - dep_files merged pluginModules + usages <- mkUsageInfo hsc_env this_mod hsc_src (imp_mods imports) used_names + dep_files merged (doc_hdr', doc_map, arg_map) <- extractDocs tc_result @@ -217,7 +222,7 @@ mkIfaceTc hsc_env safe_mode mod_details used_th deps rdr_env fix_env warns hpc_info (imp_trust_own_pkg imports) safe_mode usages - doc_hdr' doc_map arg_map + doc_hdr' doc_map arg_map mod_summary mod_details mkFullIface hsc_env partial_iface Nothing @@ -231,12 +236,13 @@ mkIface_ :: HscEnv -> Module -> HscSource -> Maybe HsDocString -> DeclDocMap -> ArgDocMap + -> ModSummary -> ModDetails -> PartialModIface mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env src_warns hpc_info pkg_trust_req safe_mode usages - doc_hdr decl_docs arg_docs + doc_hdr decl_docs arg_docs mod_summary ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -313,7 +319,9 @@ mkIface_ hsc_env mi_decl_docs = decl_docs, mi_arg_docs = arg_docs, mi_final_exts = (), - mi_ext_fields = emptyExtensibleFields } + mi_ext_fields = emptyExtensibleFields, + mi_src_hash = ms_hs_hash mod_summary + } where cmp_rule = lexicalCompareFS `on` ifRuleName -- Compare these lexicographically by OccName, *not* by unique, diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 392085f309..ee47ec97ee 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} -- | Module for detecting if recompilation is required module GHC.Iface.Recomp @@ -49,7 +50,6 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Fixity.Env -import GHC.Types.SourceFile import GHC.Unit.External import GHC.Unit.Finder @@ -66,10 +66,13 @@ import Data.Function import Data.List (sortBy, sort) import qualified Data.Map as Map import Data.Word (Word64) +import Data.Either --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<> import qualified Data.Semigroup +import GHC.List (uncons) +import Data.Ord {- ----------------------------------------------- @@ -107,11 +110,11 @@ data RecompileRequired = UpToDate -- ^ everything is up to date, recompilation is not required | MustCompile - -- ^ The .hs file has been touched, or the .o/.hi file does not exist + -- ^ The .hs file has been modified, or the .o/.hi file does not exist | RecompBecause String -- ^ The .o/.hi files are up to date, but something else has changed -- to force recompilation; the String says what (one-line summary) - deriving Eq + deriving (Eq, Show) instance Semigroup RecompileRequired where UpToDate <> r = r @@ -133,11 +136,10 @@ recompileRequired _ = True checkOldIface :: HscEnv -> ModSummary - -> SourceModified -> Maybe ModIface -- Old interface from compilation manager, if any -> IO (RecompileRequired, Maybe ModIface) -checkOldIface hsc_env mod_summary source_modified maybe_iface +checkOldIface hsc_env mod_summary maybe_iface = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env showPass logger dflags $ @@ -145,16 +147,15 @@ checkOldIface hsc_env mod_summary source_modified maybe_iface (showPpr dflags $ ms_mod mod_summary) ++ " (use -ddump-hi-diffs for more details)" initIfaceCheck (text "checkOldIface") hsc_env $ - check_old_iface hsc_env mod_summary source_modified maybe_iface + check_old_iface hsc_env mod_summary maybe_iface check_old_iface :: HscEnv -> ModSummary - -> SourceModified -> Maybe ModIface -> IfG (RecompileRequired, Maybe ModIface) -check_old_iface hsc_env mod_summary src_modified maybe_iface +check_old_iface hsc_env mod_summary maybe_iface = let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env getIface = @@ -180,11 +181,10 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface src_changed | gopt Opt_ForceRecomp dflags = True - | SourceModified <- src_modified = True | otherwise = False in do when src_changed $ - liftIO $ trace_hi_diffs logger dflags (nest 4 $ text "Source file changed or recompilation check turned off") + liftIO $ trace_hi_diffs logger dflags (nest 4 $ text "Recompilation check turned off") case src_changed of -- If the source has changed and we're in interactive mode, @@ -209,31 +209,8 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface -- even in the SourceUnmodifiedAndStable case we -- should check versions because some packages -- might have changed or gone away. - Just iface -> do - (recomp_reqd, mb_checked_iface) <- - checkVersions hsc_env mod_summary iface - return $ case mb_checked_iface of - Just iface | not (recompileRequired recomp_reqd) -> - -- If the module used TH splices when it was last - -- compiled, then the recompilation check is not - -- accurate enough (#481) and we must ignore - -- it. However, if the module is stable (none of - -- the modules it depends on, directly or - -- indirectly, changed), then we *can* skip - -- recompilation. This is why the SourceModified - -- type contains SourceUnmodifiedAndStable, and - -- it's pretty important: otherwise ghc --make - -- would always recompile TH modules, even if - -- nothing at all has changed. Stability is just - -- the same check that make is doing for us in - -- one-shot mode. - let stable = case src_modified of - SourceUnmodifiedAndStable -> True - _ -> False - in if mi_used_th iface && not stable - then (RecompBecause "TH", mb_checked_iface) - else (recomp_reqd, mb_checked_iface) - _ -> (recomp_reqd, mb_checked_iface) + Just iface -> + checkVersions hsc_env mod_summary iface -- | Check if a module is still the same 'version'. -- @@ -259,6 +236,8 @@ checkVersions hsc_env mod_summary iface -- but we ALSO must make sure the instantiation matches up. See -- test case bkpcabal04! ; hsc_env <- getTopEnv + ; if mi_src_hash iface /= ms_hs_hash mod_summary + then return (RecompBecause "Source file changed", Nothing) else do { ; if not (isHomeModule home_unit (mi_module iface)) then return (RecompBecause "-this-unit-id changed", Nothing) else do { ; recomp <- liftIO $ checkFlagHash hsc_env iface @@ -295,7 +274,7 @@ checkVersions hsc_env mod_summary iface ; recomp <- checkList [checkModUsage (homeUnitAsUnit home_unit) u | u <- mi_usages iface] ; return (recomp, Just iface) - }}}}}}}}}} + }}}}}}}}}}} where logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env @@ -389,16 +368,15 @@ checkHsig logger home_unit dflags mod_summary iface = do checkHie :: DynFlags -> ModSummary -> RecompileRequired checkHie dflags mod_summary = let hie_date_opt = ms_hie_date mod_summary - hs_date = ms_hs_date mod_summary + hi_date = ms_iface_date mod_summary in if not (gopt Opt_WriteHie dflags) then UpToDate - else case hie_date_opt of - Nothing -> RecompBecause "HIE file is missing" - Just hie_date - | hie_date < hs_date + else case (hie_date_opt, hi_date) of + (Nothing, _) -> RecompBecause "HIE file is missing" + (Just hie_date, Just hi_date) + | hie_date < hi_date -> RecompBecause "HIE file is out of date" - | otherwise - -> UpToDate + _ -> UpToDate -- | Check the flags haven't changed checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired @@ -475,41 +453,69 @@ checkMergedSignatures hsc_env mod_summary iface = do -- Returns (RecompBecause <textual reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface - = liftIO $ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) + = do + res <- liftIO $ fmap sequence $ traverse (\(mb_pkg, L _ mod) -> + let reason = moduleNameString mod ++ " changed" + in classify reason <$> findImportedModule fc units home_unit dflags mod (mb_pkg)) + (ms_imps summary ++ ms_srcimps summary) + case res of + Left recomp -> return recomp + Right es -> do + let (hs, ps) = partitionEithers es + res1 <- liftIO $ check_mods (sort hs) prev_dep_mods + + let allPkgDeps = sortBy (comparing snd) (ps ++ bkpk_units) + res2 <- liftIO $ check_packages allPkgDeps prev_dep_pkgs + return (res1 `mappend` res2) where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env fc = hsc_FC hsc_env home_unit = hsc_home_unit hsc_env units = hsc_units hsc_env - prev_dep_mods = dep_direct_mods (mi_deps iface) - prev_dep_plgn = dep_plgins (mi_deps iface) - prev_dep_pkgs = dep_direct_pkgs (mi_deps iface) - - dep_missing (mb_pkg, L _ mod) = do - find_res <- findImportedModule fc units home_unit dflags mod (mb_pkg) - let reason = moduleNameString mod ++ " changed" - case find_res of - Found _ mod - | isHomeUnit home_unit pkg - -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn - then do trace_hi_diffs logger dflags $ - text "imported module " <> quotes (ppr mod) <> - text " not among previous dependencies" - return (RecompBecause reason) - else - return UpToDate - | otherwise - -> if toUnitId pkg `notElem` prev_dep_pkgs - then do trace_hi_diffs logger dflags $ - text "imported module " <> quotes (ppr mod) <> - text " is from package " <> quotes (ppr pkg) <> - text ", which is not among previous dependencies" - return (RecompBecause reason) - else - return UpToDate - where pkg = moduleUnit mod - _otherwise -> return (RecompBecause reason) + prev_dep_mods = map gwib_mod $ dep_direct_mods (mi_deps iface) + prev_dep_pkgs = sort (dep_direct_pkgs (mi_deps iface)) + bkpk_units = map (("Signature",) . indefUnit . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) + + + + classify _ (Found _ mod) + | isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod)) + | otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod)) + classify reason _ = Left (RecompBecause reason) + + check_mods [] [] = return UpToDate + check_mods [] (old:_) = do + -- This case can happen when a module is change from HPT to package import + trace_hi_diffs logger dflags $ + text "module no longer " <> quotes (ppr old) <> + text "in dependencies" + return (RecompBecause (moduleNameString old ++ " removed")) + check_mods (new:news) olds + | Just (old, olds') <- uncons olds + , new == old = check_mods (dropWhile (== new) news) olds' + | otherwise = do + trace_hi_diffs logger dflags $ + text "imported module " <> quotes (ppr new) <> + text " not among previous dependencies" + return (RecompBecause (moduleNameString new ++ " added")) + + check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired + check_packages [] [] = return UpToDate + check_packages [] (old:_) = do + trace_hi_diffs logger dflags $ + text "package " <> quotes (ppr old) <> + text "no longer in dependencies" + return (RecompBecause (unitString old ++ " removed")) + check_packages (new:news) olds + | Just (old, olds') <- uncons olds + , snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds' + | otherwise = do + trace_hi_diffs logger dflags $ + text "imported package " <> quotes (ppr new) <> + text " not among previous dependencies" + return (RecompBecause ((fst new) ++ " package changed")) + needInterface :: Module -> (ModIface -> IO RecompileRequired) -> IfG RecompileRequired @@ -569,6 +575,13 @@ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_ha needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed (raw)" checkModuleFingerprint logger dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) +checkModUsage this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do + let mod = mkModule this_pkg mod_name + dflags <- getDynFlags + logger <- getLogger + needInterface mod $ \iface -> do + let reason = moduleNameString (moduleName mod) ++ " changed (interface)" + checkIfaceFingerprint logger dflags reason old_mod_hash (mi_iface_hash (mi_final_exts iface)) checkModUsage this_pkg UsageHomeModule{ usg_mod_name = mod_name, @@ -606,7 +619,8 @@ checkModUsage this_pkg UsageHomeModule{ checkModUsage _this_pkg UsageFile{ usg_file_path = file, - usg_file_hash = old_hash } = + usg_file_hash = old_hash, + usg_file_label = mlabel } = liftIO $ handleIO handler $ do new_hash <- getFileHash file @@ -614,7 +628,8 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file, then return recomp else return UpToDate where - recomp = RecompBecause (file ++ " changed") + reason = file ++ " changed" + recomp = RecompBecause (fromMaybe reason mlabel) handler = if debugIsOn then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp else \_ -> return recomp -- if we can't find the file, just recompile, don't fail @@ -635,6 +650,21 @@ checkModuleFingerprint logger dflags reason old_mod_hash new_mod_hash = out_of_date_hash logger dflags reason (text " Module fingerprint has changed") old_mod_hash new_mod_hash +checkIfaceFingerprint + :: Logger + -> DynFlags + -> String + -> Fingerprint + -> Fingerprint + -> IO RecompileRequired +checkIfaceFingerprint logger dflags reason old_mod_hash new_mod_hash + | new_mod_hash == old_mod_hash + = up_to_date logger dflags (text "Iface fingerprint unchanged") + + | otherwise + = out_of_date_hash logger dflags reason (text " Iface fingerprint has changed") + old_mod_hash new_mod_hash + ------------------------ checkMaybeHash :: Logger @@ -1071,12 +1101,14 @@ addFingerprints hsc_env iface0 -- The interface hash depends on: -- - the ABI hash, plus + -- - the source file hash, -- - the module level annotations, -- - usages -- - deps (home and external packages, dependent files) -- - hpc iface_hash <- computeFingerprint putNameLiterally (mod_hash, + mi_src_hash iface0, ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache mi_usages iface0, sorted_deps, @@ -1171,8 +1203,7 @@ sortDependencies d dep_trusted_pkgs = sort (dep_trusted_pkgs d), dep_boot_mods = sort (dep_boot_mods d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), - dep_finsts = sortBy stableModuleCmp (dep_finsts d), - dep_plgins = sortBy (lexicalCompareFS `on` moduleNameFS) (dep_plgins d) } + dep_finsts = sortBy stableModuleCmp (dep_finsts d) } {- ************************************************************************ diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index ccd3879910..8535bc83f2 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -15,6 +15,7 @@ module GHC.Linker.Loader , initLoaderState , uninitializedLoader , showLoaderState + , getLoaderState -- * Load & Unload , loadExpr , loadDecls @@ -98,7 +99,7 @@ import qualified Data.Set as Set import Data.Char (isSpace) import Data.Function ((&)) import Data.IORef -import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) +import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition, find) import Data.Maybe import Control.Concurrent.MVar import qualified Control.Monad.Catch as MC @@ -113,6 +114,8 @@ import System.Win32.Info (getSystemDirectory) #endif import GHC.Utils.Exception +import qualified Data.Map as M +import Data.Either (partitionEithers) uninitialised :: a uninitialised = panic "Loader not initialised" @@ -128,6 +131,10 @@ modifyLoaderState interp f = (fmapFst pure . f . fromMaybe uninitialised) where fmapFst f = fmap (\(x, y) -> (f x, y)) +getLoaderState :: Interp -> IO (Maybe LoaderState) +getLoaderState interp = readMVar (loader_state (interpLoader interp)) + + emptyLoaderState :: LoaderState emptyLoaderState = LoaderState { closure_env = emptyNameEnv @@ -135,6 +142,9 @@ emptyLoaderState = LoaderState , pkgs_loaded = init_pkgs , bcos_loaded = [] , objs_loaded = [] + , hs_objs_loaded = [] + , non_hs_objs_loaded = [] + , module_deps = M.empty , temp_sos = [] } -- Packages that don't need loading, because the compiler @@ -166,14 +176,14 @@ deleteFromLoadedEnv interp to_remove = -- | Load the module containing the given Name and get its associated 'HValue'. -- -- Throws a 'ProgramError' if loading fails or the name cannot be found. -loadName :: Interp -> HscEnv -> Name -> IO ForeignHValue -loadName interp hsc_env name = do +loadName :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> IO ForeignHValue +loadName interp hsc_env mnwib name = do initLoaderState interp hsc_env modifyLoaderState interp $ \pls0 -> do pls <- if not (isExternalName name) then return pls0 else do - (pls', ok) <- loadDependencies interp hsc_env pls0 noSrcSpan + (pls', ok) <- loadDependencies interp hsc_env pls0 (noSrcSpan, mnwib) [nameModule name] if failed ok then throwGhcExceptionIO (ProgramError "") @@ -194,7 +204,7 @@ loadDependencies :: Interp -> HscEnv -> LoaderState - -> SrcSpan -> [Module] + -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> [Module] -> IO (LoaderState, SuccessFlag) loadDependencies interp hsc_env pls span needed_mods = do -- initLoaderState (hsc_dflags hsc_env) dl @@ -204,15 +214,20 @@ loadDependencies interp hsc_env pls span needed_mods = do -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. -- So here we check the build tag: if we're building a non-standard way -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay dflags interp span + maybe_normal_osuf <- checkNonStdWay dflags interp (fst span) -- Find what packages and linkables are required - (lnks, pkgs) <- getLinkDeps hsc_env hpt pls - maybe_normal_osuf span needed_mods + (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env hpt pls + maybe_normal_osuf (fst span) needed_mods + + let pls1 = + case (snd span) of + Just mn -> pls { module_deps = M.insertWith (++) mn all_lnks (module_deps pls) } + Nothing -> pls -- Link the packages and modules required - pls1 <- loadPackages' interp hsc_env pkgs pls - loadModules interp hsc_env pls1 lnks + pls2 <- loadPackages' interp hsc_env pkgs pls1 + loadModules interp hsc_env pls2 lnks -- | Temporarily extend the loaded env. @@ -547,7 +562,7 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do -- Raises an IO exception ('ProgramError') if it can't find a compiled -- version of the dependents to load. -- -loadExpr :: Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue +loadExpr :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> UnlinkedBCO -> IO ForeignHValue loadExpr interp hsc_env span root_ul_bco = do -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env @@ -636,7 +651,7 @@ getLinkDeps :: HscEnv -> HomePackageTable -> Maybe FilePath -- replace object suffices? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [UnitId]) -- ... then link these first + -> IO ([Linkable], [Linkable], [UnitId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env hpt pls replace_osuf span mods @@ -647,14 +662,17 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) emptyUniqDSet emptyUniqDSet; - ; let { + ; let -- 2. Exclude ones already linked -- Main reason: avoid findModule calls in get_linkable - mods_needed = mods_s `minusList` linked_mods ; - pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; + (mods_needed, mods_got) = partitionEithers (map split_mods mods_s) + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls - linked_mods = map (moduleName.linkableModule) - (objs_loaded pls ++ bcos_loaded pls) } + split_mods mod_name = + let is_linked = find ((== mod_name) . (moduleName . linkableModule)) (objs_loaded pls ++ bcos_loaded pls) + in case is_linked of + Just linkable -> Right linkable + Nothing -> Left mod_name -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot @@ -662,7 +680,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods ; let { osuf = objectSuf dflags } ; lnks_needed <- mapM (get_linkable osuf) mods_needed - ; return (lnks_needed, pkgs_needed) } + ; return (lnks_needed, mods_got ++ lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env @@ -779,7 +797,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods ********************************************************************* -} -loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO () +loadDecls :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CompiledByteCode -> IO () loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env @@ -822,11 +840,11 @@ loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do ********************************************************************* -} -loadModule :: Interp -> HscEnv -> Module -> IO () -loadModule interp hsc_env mod = do +loadModule :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Module -> IO () +loadModule interp hsc_env mnwib mod = do initLoaderState interp hsc_env modifyLoaderState_ interp $ \pls -> do - (pls', ok) <- loadDependencies interp hsc_env pls noSrcSpan [mod] + (pls', ok) <- loadDependencies interp hsc_env pls (noSrcSpan, mnwib) [mod] if failed ok then throwGhcExceptionIO (ProgramError "could not load module") else return pls' @@ -1184,40 +1202,6 @@ unload_wkr interp keep_linkables pls@LoaderState{..} = do -- letting go of them (plus of course depopulating -- the symbol table which is done in the main body) -{- ********************************************************************** - - Loading packages - - ********************************************************************* -} - -data LibrarySpec - = Objects [FilePath] -- Full path names of set of .o files, including trailing .o - -- We allow batched loading to ensure that cyclic symbol - -- references can be resolved (see #13786). - -- For dynamic objects only, try to find the object - -- file in all the directories specified in - -- v_Library_paths before giving up. - - | Archive FilePath -- Full path name of a .a file, including trailing .a - - | DLL String -- "Unadorned" name of a .DLL/.so - -- e.g. On unix "qt" denotes "libqt.so" - -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" - -- loadDLL is platform-specific and adds the lib/.so/.DLL - -- suffixes platform-dependently - - | DLLPath FilePath -- Absolute or relative pathname to a dynamic library - -- (ends with .dll or .so). - - | Framework String -- Only used for darwin, but does no harm - -instance Outputable LibrarySpec where - ppr (Objects objs) = text "Objects" <+> ppr objs - ppr (Archive a) = text "Archive" <+> text a - ppr (DLL s) = text "DLL" <+> text s - ppr (DLLPath f) = text "DLLPath" <+> text f - ppr (Framework s) = text "Framework" <+> text s - -- If this package is already part of the GHCi binary, we'll already -- have the right DLLs for this package loaded, so don't try to -- load them again. @@ -1263,29 +1247,31 @@ loadPackages interp hsc_env new_pkgs = do loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState loadPackages' interp hsc_env new_pks pls = do - pkgs' <- link (pkgs_loaded pls) new_pks - return $! pls { pkgs_loaded = pkgs' } + (pkgs', hs_objs, non_hs_objs) <- link (pkgs_loaded pls) new_pks + return $! pls { pkgs_loaded = pkgs' + , hs_objs_loaded = hs_objs ++ hs_objs_loaded pls + , non_hs_objs_loaded = non_hs_objs ++ non_hs_objs_loaded pls } where - link :: [UnitId] -> [UnitId] -> IO [UnitId] + link :: [UnitId] -> [UnitId] -> IO ([UnitId], [LibrarySpec], [LibrarySpec]) link pkgs new_pkgs = - foldM link_one pkgs new_pkgs + foldM link_one (pkgs, [],[]) new_pkgs - link_one pkgs new_pkg + link_one (pkgs, acc_hs, acc_non_hs) new_pkg | new_pkg `elem` pkgs -- Already linked - = return pkgs + = return (pkgs, acc_hs, acc_non_hs) | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg = do { -- Link dependents first - pkgs' <- link pkgs (unitDepends pkg_cfg) + (pkgs', hs_cls', extra_cls') <- link pkgs (unitDepends pkg_cfg) -- Now link the package itself - ; loadPackage interp hsc_env pkg_cfg - ; return (new_pkg : pkgs') } + ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg + ; return (new_pkg : pkgs', acc_hs ++ hs_cls ++ hs_cls', acc_non_hs ++ extra_cls ++ extra_cls') } | otherwise = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO () +loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec]) loadPackage interp hsc_env pkg = do let dflags = hsc_dflags hsc_env @@ -1369,7 +1355,9 @@ loadPackage interp hsc_env pkg mapM_ (removeLibrarySearchPath interp) $ reverse pathCache if succeeded ok - then maybePutStrLn logger dflags "done." + then do + maybePutStrLn logger dflags "done." + return (hs_classifieds, extra_classifieds) else let errmsg = text "unable to load unit `" <> pprUnitInfoForUser pkg <> text "'" in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs index 728d6a3b06..e0d04f5bfa 100644 --- a/compiler/GHC/Linker/Types.hs +++ b/compiler/GHC/Linker/Types.hs @@ -17,13 +17,15 @@ module GHC.Linker.Types , linkableObjs , isObject , nameOfObject + , nameOfObject_maybe , isInterpretable , byteCodeOfObject + , LibrarySpec(..) ) where import GHC.Prelude -import GHC.Unit ( UnitId, Module ) +import GHC.Unit ( UnitId, Module, ModuleNameWithIsBoot ) import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint ) import GHCi.RemoteTypes ( ForeignHValue ) @@ -37,6 +39,8 @@ import GHC.Utils.Panic import Control.Concurrent.MVar import Data.Time ( UTCTime ) +import Data.Maybe +import qualified Data.Map as M {- ********************************************************************** @@ -81,6 +85,9 @@ data LoaderState = LoaderState -- ^ The currently-loaded packages; always object code -- Held, as usual, in dependency order; though I am not sure if -- that is really important + , hs_objs_loaded :: ![LibrarySpec] + , non_hs_objs_loaded :: ![LibrarySpec] + , module_deps :: M.Map ModuleNameWithIsBoot [Linkable] , temp_sos :: ![(FilePath, String)] -- ^ We need to remember the name of previous temporary DLL/.so @@ -102,10 +109,6 @@ data Linkable = LM { -- ^ Those files and chunks of code we have yet to link. -- -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. - -- If this list is empty, the Linkable represents a fake linkable, which - -- is generated with no backend is used to avoid recompiling modules. - -- - -- ToDo: Do items get removed from this list when they get linked? } instance Outputable Linkable where @@ -163,14 +166,51 @@ isObject _ = False isInterpretable :: Unlinked -> Bool isInterpretable = not . isObject +nameOfObject_maybe :: Unlinked -> Maybe FilePath +nameOfObject_maybe (DotO fn) = Just fn +nameOfObject_maybe (DotA fn) = Just fn +nameOfObject_maybe (DotDLL fn) = Just fn +nameOfObject_maybe (BCOs {}) = Nothing + -- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object nameOfObject :: Unlinked -> FilePath -nameOfObject (DotO fn) = fn -nameOfObject (DotA fn) = fn -nameOfObject (DotDLL fn) = fn -nameOfObject other = pprPanic "nameOfObject" (ppr other) +nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o) -- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable byteCodeOfObject :: Unlinked -> CompiledByteCode byteCodeOfObject (BCOs bc _) = bc byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) + +{- ********************************************************************** + + Loading packages + + ********************************************************************* -} + +data LibrarySpec + = Objects [FilePath] -- Full path names of set of .o files, including trailing .o + -- We allow batched loading to ensure that cyclic symbol + -- references can be resolved (see #13786). + -- For dynamic objects only, try to find the object + -- file in all the directories specified in + -- v_Library_paths before giving up. + + | Archive FilePath -- Full path name of a .a file, including trailing .a + + | DLL String -- "Unadorned" name of a .DLL/.so + -- e.g. On unix "qt" denotes "libqt.so" + -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" + -- loadDLL is platform-specific and adds the lib/.so/.DLL + -- suffixes platform-dependently + + | DLLPath FilePath -- Absolute or relative pathname to a dynamic library + -- (ends with .dll or .so). + + | Framework String -- Only used for darwin, but does no harm + +instance Outputable LibrarySpec where + ppr (Objects objs) = text "Objects" <+> ppr objs + ppr (Archive a) = text "Archive" <+> text a + ppr (DLL s) = text "DLL" <+> text s + ppr (DLLPath f) = text "DLLPath" <+> text f + ppr (Framework s) = text "Framework" <+> text s diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index a50701b764..6d4806fe47 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -109,7 +109,7 @@ we must also check that these rules hold transitively for all dependent modules and packages. Doing this without caching any trust information would be very slow as we would need to touch all packages and interface files a module depends on. To avoid this we make use of the property that if a modules Safe Haskell -mode changes, this triggers a recompilation from that module in the dependcy +mode changes, this triggers a recompilation from that module in the dependecy graph. So we can just worry mostly about direct imports. There is one trust property that can change for a package though without diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 97c26099d4..7f6bf2009a 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -1275,13 +1275,13 @@ obtainTermFromVal hsc_env _bound _force _ty _x = case interpInstance interp of obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id = do - hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id) + hv <- Loader.loadName (hscInterp hsc_env) hsc_env Nothing (varName id) cvObtainTerm hsc_env bound force (idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do - hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id) + hv <- Loader.loadName (hscInterp hsc_env) hsc_env Nothing (varName id) cvReconstructType hsc_env bound (idType id) hv mkRuntimeUnkTyVar :: Name -> Kind -> TyVar diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 6c590b5790..3eef85f715 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -63,20 +63,21 @@ import GHC.Utils.Exception import Control.Monad ( unless ) import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce ) +import GHC.Unit.Types (ModuleNameWithIsBoot) -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before -- actual compilation starts. Idempotent operation. Should be re-called if -- pluginModNames or pluginModNameOpts changes. -initializePlugins :: HscEnv -> IO HscEnv -initializePlugins hsc_env +initializePlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO HscEnv +initializePlugins hsc_env mnwib -- plugins not changed | map lpModuleName (hsc_plugins hsc_env) == pluginModNames dflags -- arguments not changed , all same_args (hsc_plugins hsc_env) = return hsc_env -- no need to reload plugins | otherwise - = do loaded_plugins <- loadPlugins hsc_env + = do loaded_plugins <- loadPlugins hsc_env mnwib let hsc_env' = hsc_env { hsc_plugins = loaded_plugins } withPlugins hsc_env' driverPlugin hsc_env' where @@ -85,8 +86,8 @@ initializePlugins hsc_env argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) dflags = hsc_dflags hsc_env -loadPlugins :: HscEnv -> IO [LoadedPlugin] -loadPlugins hsc_env +loadPlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO [LoadedPlugin] +loadPlugins hsc_env mnwib = do { unless (null to_load) $ checkExternalInterpreter hsc_env ; plugins <- mapM loadPlugin to_load @@ -100,14 +101,14 @@ loadPlugins hsc_env where options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags , opt_mod_nm == mod_nm ] - loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env + loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env mnwib loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin loadFrontendPlugin hsc_env mod_name = do checkExternalInterpreter hsc_env fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName - hsc_env mod_name + hsc_env Nothing mod_name -- #14335 checkExternalInterpreter :: HscEnv -> IO () @@ -116,8 +117,8 @@ checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of -> throwIO (InstallationError "Plugins require -fno-external-interpreter") _ -> pure () -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) -loadPlugin' occ_name plugin_name hsc_env mod_name +loadPlugin' :: OccName -> Name -> HscEnv -> Maybe ModuleNameWithIsBoot -> ModuleName -> IO (a, ModIface) +loadPlugin' occ_name plugin_name hsc_env mnwib mod_name = do { let plugin_rdr_name = mkRdrQual mod_name occ_name dflags = hsc_dflags hsc_env ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name @@ -131,7 +132,7 @@ loadPlugin' occ_name plugin_name hsc_env mod_name Just (name, mod_iface) -> do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name - ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; mb_plugin <- getValueSafely hsc_env mnwib name (mkTyConTy plugin_tycon) ; case mb_plugin of Nothing -> throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep @@ -183,11 +184,11 @@ forceLoadTyCon hsc_env con_name = do -- * If the Name does not exist in the module -- * If the link failed -getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) -getValueSafely hsc_env val_name expected_type = do +getValueSafely :: HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Maybe a) +getValueSafely hsc_env mnwib val_name expected_type = do mb_hval <- case getValueSafelyHook hooks of - Nothing -> getHValueSafely interp hsc_env val_name expected_type - Just h -> h hsc_env val_name expected_type + Nothing -> getHValueSafely interp hsc_env mnwib val_name expected_type + Just h -> h hsc_env mnwib val_name expected_type case mb_hval of Nothing -> return Nothing Just hval -> do @@ -199,8 +200,8 @@ getValueSafely hsc_env val_name expected_type = do logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env -getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Maybe HValue) -getHValueSafely interp hsc_env val_name expected_type = do +getHValueSafely :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Maybe HValue) +getHValueSafely interp hsc_env mnwib val_name expected_type = do forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name -- Now look up the names for the value and type constructor in the type environment mb_val_thing <- lookupType hsc_env val_name @@ -213,12 +214,12 @@ getHValueSafely interp hsc_env val_name expected_type = do then do -- Link in the module that contains the value, if it has such a module case nameModule_maybe val_name of - Just mod -> do loadModule interp hsc_env mod + Just mod -> do loadModule interp hsc_env mnwib mod return () Nothing -> return () -- Find the value that we just linked in and cast it given that we have proved it's type hval <- do - v <- loadName interp hsc_env val_name + v <- loadName interp hsc_env mnwib val_name wormhole interp v return (Just hval) else return Nothing diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 3c0c85f7c4..056855469d 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1006,9 +1006,10 @@ runMeta' show_code ppr_hs run_and_convert expr -- Compile and link it; might fail if linking fails ; src_span <- getSrcSpanM + ; mnwib <- getMnwib ; traceTc "About to run (desugared)" (ppr ds_expr) ; either_hval <- tryM $ liftIO $ - GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr + GHC.Driver.Main.hscCompileCoreExpr hsc_env (src_span, Just mnwib) ds_expr ; case either_hval of { Left exn -> fail_with_exn "compile and link" exn ; Right hval -> do @@ -2611,6 +2612,7 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m + usageToModule this_pkg (UsageHomeModuleInterface { usg_mod_name = mn }) = Just $ mkModule this_pkg mn ------------------------------ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index e385322223..8b59f14fab 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -57,7 +57,7 @@ module GHC.Tc.Utils.Monad( getRdrEnvs, getImports, getFixityEnv, extendFixityEnv, getRecFieldEnv, getDeclaredDefaultTys, - addDependentFiles, + addDependentFiles, getMnwib, -- * Error management getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode, @@ -899,6 +899,11 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) } +getMnwib :: TcRn ModuleNameWithIsBoot +getMnwib = do + gbl_env <- getGblEnv + return $ GWIB (moduleName $ tcg_mod gbl_env) (hscSourceToIsBoot (tcg_src gbl_env)) + -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = tcl_in_gen_code <$> getLclEnv diff --git a/compiler/GHC/Types/SourceFile.hs b/compiler/GHC/Types/SourceFile.hs index e8faec7a58..7a1898a51e 100644 --- a/compiler/GHC/Types/SourceFile.hs +++ b/compiler/GHC/Types/SourceFile.hs @@ -1,6 +1,6 @@ module GHC.Types.SourceFile ( HscSource(..) - , SourceModified (..) + , hscSourceToIsBoot , isHsBootOrSig , isHsigFile , hscSourceString @@ -9,6 +9,7 @@ where import GHC.Prelude import GHC.Utils.Binary +import GHC.Unit.Types -- Note [HscSource types] -- ~~~~~~~~~~~~~~~~~~~~~~ @@ -49,6 +50,14 @@ data HscSource | HsigFile -- ^ .hsig file deriving (Eq, Ord, Show) +-- | Tests if an 'HscSource' is a boot file, primarily for constructing elements +-- of 'BuildModule'. We conflate signatures and modules because they are bound +-- in the same namespace; only boot interfaces can be disambiguated with +-- `import {-# SOURCE #-}`. +hscSourceToIsBoot :: HscSource -> IsBootInterface +hscSourceToIsBoot HsBootFile = IsBoot +hscSourceToIsBoot _ = NotBoot + instance Binary HscSource where put_ bh HsSrcFile = putByte bh 0 put_ bh HsBootFile = putByte bh 1 @@ -74,21 +83,3 @@ isHsBootOrSig _ = False isHsigFile :: HscSource -> Bool isHsigFile HsigFile = True isHsigFile _ = False - --- | Indicates whether a given module's source has been modified since it --- was last compiled. -data SourceModified - = SourceModified - -- ^ the source has been modified - | SourceUnmodified - -- ^ the source has not been modified. Compilation may or may - -- not be necessary, depending on whether any dependencies have - -- changed since we last compiled. - | SourceUnmodifiedAndStable - -- ^ the source has not been modified, and furthermore all of - -- its (transitive) dependencies are up to date; it definitely - -- does not need to be recompiled. This is important for two - -- reasons: (a) we can omit the version check in checkOldIface, - -- and (b) if the module used TH splices we don't need to force - -- recompilation. - diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs index 2de3fe710d..2cafbbdcd4 100644 --- a/compiler/GHC/Unit/Module/Deps.hs +++ b/compiler/GHC/Unit/Module/Deps.hs @@ -32,9 +32,6 @@ data Dependencies = Deps -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong. -- - , dep_plgins :: [ModuleName] - -- ^ All the plugins used while compiling this module. - -- Transitive information below here , dep_sig_mods :: ![ModuleName] @@ -82,7 +79,6 @@ instance Binary Dependencies where put_ bh (dep_boot_mods deps) put_ bh (dep_orphs deps) put_ bh (dep_finsts deps) - put_ bh (dep_plgins deps) get bh = do dms <- get bh dps <- get bh @@ -91,17 +87,16 @@ instance Binary Dependencies where sms <- get bh os <- get bh fis <- get bh - pl <- get bh return (Deps { dep_direct_mods = dms , dep_direct_pkgs = dps , dep_sig_mods = hsigms , dep_boot_mods = sms , dep_trusted_pkgs = tps , dep_orphs = os, - dep_finsts = fis, dep_plgins = pl }) + dep_finsts = fis }) noDependencies :: Dependencies -noDependencies = Deps [] [] [] [] [] [] [] [] +noDependencies = Deps [] [] [] [] [] [] [] -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance @@ -141,14 +136,31 @@ data Usage usg_file_path :: FilePath, -- ^ External file dependency. From a CPP #include or TH -- addDependentFile. Should be absolute. - usg_file_hash :: Fingerprint + usg_file_hash :: Fingerprint, -- ^ 'Fingerprint' of the file contents. + usg_file_label :: Maybe String + -- ^ An optional string which is used in recompilation messages if + -- file in question has changed. + -- Note: We don't consider things like modification timestamps -- here, because there's no reason to recompile if the actual -- contents don't change. This previously lead to odd -- recompilation behaviors; see #8114 } + | UsageHomeModuleInterface { + usg_mod_name :: ModuleName + -- ^ Name of the module + , usg_iface_hash :: Fingerprint + -- ^ The *interface* hash of the module, not the ABI hash. + -- This changes when anything about the interface (and hence the + -- module) has changed. + + -- UsageHomeModuleInterface is *only* used for recompilation + -- checking when using TemplateHaskell in the interpreter (where + -- some modules are loaded as BCOs). + + } -- | A requirement which was merged into this one. | UsageMergedRequirement { usg_mod :: Module, @@ -187,12 +199,18 @@ instance Binary Usage where putByte bh 2 put_ bh (usg_file_path usg) put_ bh (usg_file_hash usg) + put_ bh (usg_file_label usg) put_ bh usg@UsageMergedRequirement{} = do putByte bh 3 put_ bh (usg_mod usg) put_ bh (usg_mod_hash usg) + put_ bh usg@UsageHomeModuleInterface{} = do + putByte bh 4 + put_ bh (usg_mod_name usg) + put_ bh (usg_iface_hash usg) + get bh = do h <- getByte bh case h of @@ -212,11 +230,16 @@ instance Binary Usage where 2 -> do fp <- get bh hash <- get bh - return UsageFile { usg_file_path = fp, usg_file_hash = hash } + label <- get bh + return UsageFile { usg_file_path = fp, usg_file_hash = hash, usg_file_label = label } 3 -> do mod <- get bh hash <- get bh return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } + 4 -> do + mod <- get bh + hash <- get bh + return UsageHomeModuleInterface { usg_mod_name = mod, usg_iface_hash = hash } i -> error ("Binary.get(Usage): " ++ show i) diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs index 640c258273..b40c980744 100644 --- a/compiler/GHC/Unit/Module/ModGuts.hs +++ b/compiler/GHC/Unit/Module/ModGuts.hs @@ -1,5 +1,6 @@ module GHC.Unit.Module.ModGuts ( ModGuts (..) + , mg_mnwib , CgGuts (..) ) where @@ -31,7 +32,7 @@ import GHC.Types.ForeignStubs import GHC.Types.HpcInfo import GHC.Types.Name.Reader import GHC.Types.SafeHaskell -import GHC.Types.SourceFile ( HscSource(..) ) +import GHC.Types.SourceFile ( HscSource(..), hscSourceToIsBoot ) import GHC.Types.SrcLoc @@ -96,6 +97,9 @@ data ModGuts mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. } +mg_mnwib :: ModGuts -> ModuleNameWithIsBoot +mg_mnwib mg = GWIB (moduleName (mg_module mg)) (hscSourceToIsBoot (mg_hsc_src mg)) + -- The ModGuts takes on several slightly different forms: -- -- After simplification, the following fields change slightly: diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs index 18101e309b..695e1ff6c2 100644 --- a/compiler/GHC/Unit/Module/ModIface.hs +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -242,13 +242,17 @@ data ModIface_ (phase :: ModIfacePhase) -- ^ Either `()` or `ModIfaceBackend` for -- a fully instantiated interface. - mi_ext_fields :: ExtensibleFields + mi_ext_fields :: ExtensibleFields, -- ^ Additional optional fields, where the Map key represents -- the field name, resulting in a (size, serialized data) pair. -- Because the data is intended to be serialized through the -- internal `Binary` class (increasing compatibility with types -- using `Name` and `FastString`, such as HIE), this format is -- chosen over `ByteString`s. + -- + + mi_src_hash :: !Fingerprint + -- ^ Hash of the .hs source, used for recompilation checking. } -- | Old-style accessor for whether or not the ModIface came from an hs-boot @@ -305,6 +309,9 @@ instance Binary ModIface where mi_module = mod, mi_sig_of = sig_of, mi_hsc_src = hsc_src, + mi_src_hash = _src_hash, -- Don't `put_` this in the instance + -- because we are going to write it + -- out separately in the actual file mi_deps = deps, mi_usages = usages, mi_exports = exports, @@ -406,6 +413,8 @@ instance Binary ModIface where mi_module = mod, mi_sig_of = sig_of, mi_hsc_src = hsc_src, + mi_src_hash = fingerprint0, -- placeholder because this is dealt + -- with specially when the file is read mi_deps = deps, mi_usages = usages, mi_exports = exports, @@ -452,6 +461,7 @@ emptyPartialModIface mod = ModIface { mi_module = mod, mi_sig_of = Nothing, mi_hsc_src = HsSrcFile, + mi_src_hash = fingerprint0, mi_deps = noDependencies, mi_usages = [], mi_exports = [], @@ -512,11 +522,11 @@ emptyIfaceHashCache _occ = Nothing -- avoid major space leaks. instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 - f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) = + f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25) = rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 - `seq` rnf f24 + `seq` rnf f24 `seq` f25 `seq` () -- | Records whether a module has orphans. An \"orphan\" is one of: -- diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs index 324cca33a3..339afd4564 100644 --- a/compiler/GHC/Unit/Module/ModSummary.hs +++ b/compiler/GHC/Unit/Module/ModSummary.hs @@ -10,6 +10,7 @@ module GHC.Unit.Module.ModSummary , ms_installed_mod , ms_mod_name , ms_imps + , ms_mnwib , ms_home_allimps , ms_home_srcimps , ms_home_imps @@ -39,6 +40,7 @@ import GHC.Data.Maybe import GHC.Data.FastString import GHC.Data.StringBuffer ( StringBuffer ) +import GHC.Utils.Fingerprint import GHC.Utils.Outputable import Data.Time @@ -73,14 +75,15 @@ data ModSummary -- ^ The module source either plain Haskell, hs-boot, or hsig ms_location :: ModLocation, -- ^ Location of the various files belonging to the module - ms_hs_date :: UTCTime, - -- ^ Timestamp of source file + ms_hs_hash :: Fingerprint, + -- ^ Content hash of source file ms_obj_date :: Maybe UTCTime, -- ^ Timestamp of object, if we have one + ms_dyn_obj_date :: !(Maybe UTCTime), + -- ^ Timestamp of dynamic object, if we have one ms_iface_date :: Maybe UTCTime, - -- ^ Timestamp of hi file, if we *only* are typechecking (it is - -- 'Nothing' otherwise. - -- See Note [Recompilation checking in -fno-code mode] and #9243 + -- ^ Timestamp of hi file, if we have one + -- See Note [When source is considered modified] and #9243 ms_hie_date :: Maybe UTCTime, -- ^ Timestamp of hie file, if we have one ms_srcimps :: [(Maybe FastString, Located ModuleName)], @@ -145,7 +148,7 @@ ms_home_imps = home_imps . ms_imps -- and let @compile@ read from that file on the way back up. -- The ModLocation is stable over successive up-sweeps in GHCi, wheres --- the ms_hs_date and imports can, of course, change +-- the ms_hs_hash and imports can, of course, change msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) @@ -159,10 +162,13 @@ msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms) isBootSummary :: ModSummary -> IsBootInterface isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot +ms_mnwib :: ModSummary -> ModuleNameWithIsBoot +ms_mnwib ms = GWIB (ms_mod_name ms) (isBootSummary ms) + instance Outputable ModSummary where ppr ms = sep [text "ModSummary {", - nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + nest 3 (sep [text "ms_hs_hash = " <> text (show (ms_hs_hash ms)), text "ms_mod =" <+> ppr (ms_mod ms) <> text (hscSourceString (ms_hsc_src ms)) <> comma, text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), @@ -170,6 +176,8 @@ instance Outputable ModSummary where char '}' ] +-- | Find the first target in the provided list which matches the specified +-- 'ModSummary'. findTarget :: ModSummary -> [Target] -> Maybe Target findTarget ms ts = case filter (matches ms) ts of diff --git a/compiler/GHC/Unit/Module/Status.hs b/compiler/GHC/Unit/Module/Status.hs index e4273de94b..6f926e3fb2 100644 --- a/compiler/GHC/Unit/Module/Status.hs +++ b/compiler/GHC/Unit/Module/Status.hs @@ -10,11 +10,13 @@ import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface import GHC.Utils.Fingerprint +import GHC.Linker.Types +import GHC.Utils.Outputable -- | Status of a module in incremental compilation data HscRecompStatus -- | Nothing to do because code already exists. - = HscUpToDate ModIface + = HscUpToDate ModIface (Maybe Linkable) -- | Recompilation of module, or update of interface is required. Optionally -- pass the old interface hash to avoid updating the existing interface when -- it has not changed. @@ -38,3 +40,8 @@ data HscBackendAction -- avoid updating the existing interface when the interface isn't -- changed. } + + +instance Outputable HscBackendAction where + ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi)) + ppr (HscRecomp _ ml _mi _mf) = text "Recomp:" <+> ppr ml diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 8dde1c7296..d19d78c876 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -66,7 +66,7 @@ module GHC.Utils.Misc ( dropTail, capitalise, -- * Sorting - sortWith, minWith, nubSort, ordNub, + sortWith, minWith, nubSort, ordNub, ordNubOn, -- * Comparisons isEqual, eqListBy, eqMaybeBy, @@ -100,6 +100,7 @@ module GHC.Utils.Misc ( doesDirNameExist, getModificationUTCTime, modificationTimeIfExists, + fileHashIfExists, withAtomicRename, -- * Filenames and paths @@ -132,6 +133,7 @@ import GHC.Prelude import GHC.Utils.Exception import GHC.Utils.Panic.Plain import GHC.Utils.Constants +import GHC.Utils.Fingerprint import Data.Data import qualified Data.List as List @@ -639,13 +641,18 @@ nubSort = Set.toAscList . Set.fromList -- | Remove duplicates but keep elements in order. -- O(n * log n) ordNub :: Ord a => [a] -> [a] -ordNub xs +ordNub xs = ordNubOn id xs + +-- | Remove duplicates but keep elements in order. +-- O(n * log n) +ordNubOn :: Ord b => (a -> b) -> [a] -> [a] +ordNubOn f xs = go Set.empty xs where go _ [] = [] go s (x:xs) - | Set.member x s = go s xs - | otherwise = x : go (Set.insert x s) xs + | Set.member (f x) s = go s xs + | otherwise = x : go (Set.insert (f x) s) xs {- @@ -1292,6 +1299,16 @@ modificationTimeIfExists f = else ioError e -- -------------------------------------------------------------- +-- check existence & hash at the same time + +fileHashIfExists :: FilePath -> IO (Maybe Fingerprint) +fileHashIfExists f = + (do t <- getFileHash f; return (Just t)) + `catchIO` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- -------------------------------------------------------------- -- atomic file writing by writing to a temporary file first (see #14533) -- -- This should be used in all cases where GHC writes files to disk diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index d6c79895d5..7d33007ead 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -134,6 +134,8 @@ import Data.Graph (SCC(..)) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL +import Data.Time +import Data.Time.Format.ISO8601 import GHC.Fingerprint import GHC.Show ( showMultiLineString ) @@ -918,6 +920,9 @@ instance Outputable Double where instance Outputable () where ppr _ = text "()" +instance Outputable UTCTime where + ppr = text . formatShow iso8601Format + instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) diff --git a/docs/users_guide/separate_compilation.rst b/docs/users_guide/separate_compilation.rst index f5c53171ac..9d11830237 100644 --- a/docs/users_guide/separate_compilation.rst +++ b/docs/users_guide/separate_compilation.rst @@ -659,14 +659,15 @@ jot. So now… GHC calculates a fingerprint (in fact an MD5 hash) of each interface file, and of each declaration within the interface file. It also keeps in every interface file a list of the fingerprints of everything it used -when it last compiled the file. If the source file's modification date -is earlier than the ``.o`` file's date (i.e. the source hasn't changed -since the file was last compiled), and the recompilation checking is on, -GHC will be clever. It compares the fingerprints on the things it needs -this time with the fingerprints on the things it needed last time -(gleaned from the interface file of the module being compiled); if they -are all the same it stops compiling early in the process saying -“Compilation IS NOT required”. What a beautiful sight! +when it last compiled the file. If the MD5 hash of the source file +stored in the ``.hi`` file hasn't changed, the ``.o`` file's +modification date is greater than or equal to that of the ``.hi`` file, +and the recompilation checking is on, GHC will be clever. It compares +the fingerprints on the things it needs this time with the fingerprints +on the things it needed last time (gleaned from the interface file of +the module being compiled); if they are all the same it stops compiling +early in the process saying “Compilation IS NOT required”. What a +beautiful sight! You can read about :ghc-wiki:`how all this works <commentary/compiler/recompilation-avoidance>` in the GHC commentary. diff --git a/testsuite/driver/testglobals.py b/testsuite/driver/testglobals.py index c7140387af..dd063f0c73 100644 --- a/testsuite/driver/testglobals.py +++ b/testsuite/driver/testglobals.py @@ -421,6 +421,9 @@ class TestOptions: # in temporary directory in /tmp? See Note [Running tests in /tmp]. self.local = True + # Should we copy the files of symlink the files for the test? + self.copy_files = False + # The default set of options global default_testopts default_testopts = TestOptions() diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index 13c32da1f6..57bfe82bae 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -695,6 +695,11 @@ def _outputdir( name, opts, odir ): # ---- +def copy_files(name, opts): + opts.copy_files = True + +# ---- + def pre_cmd( cmd ): return lambda name, opts, c=cmd: _pre_cmd(name, opts, cmd) @@ -1133,13 +1138,14 @@ def do_test(name: TestName, for extra_file in files: src = in_srcdir(extra_file) dst = in_testdir(os.path.basename(extra_file.rstrip('/\\'))) + force_copy = opts.copy_files if src.is_file(): - link_or_copy_file(src, dst) + link_or_copy_file(src, dst, force_copy) elif src.is_dir(): if dst.exists(): shutil.rmtree(str(dst)) dst.mkdir() - lndir(src, dst) + lndir(src, dst, force_copy) else: if not config.haddock and os.path.splitext(extra_file)[1] == '.t': # When using a ghc built without haddock support, .t diff --git a/testsuite/driver/testutil.py b/testsuite/driver/testutil.py index bcea98bd17..48f33b1540 100644 --- a/testsuite/driver/testutil.py +++ b/testsuite/driver/testutil.py @@ -62,7 +62,7 @@ def getStdout(cmd_and_args: List[str]): raise Exception("stderr from command: %s\nOutput:\n%s\n" % (cmd_and_args, stderr.decode('utf-8'))) return stdout.decode('utf-8') -def lndir(srcdir: Path, dstdir: Path): +def lndir(srcdir: Path, dstdir: Path, force_copy=False): # Create symlinks for all files in src directory. # Not all developers might have lndir installed. # os.system('lndir -silent {0} {1}'.format(srcdir, dstdir)) @@ -71,7 +71,7 @@ def lndir(srcdir: Path, dstdir: Path): src = srcdir / base dst = dstdir / base if src.is_file(): - link_or_copy_file(src, dst) + link_or_copy_file(src, dst, force_copy) else: dst.mkdir() lndir(src, dst) @@ -116,11 +116,14 @@ def symlinks_work() -> bool: return True if not symlinks_work(): - def link_or_copy_file(src: Path, dst: Path): + def link_or_copy_file(src: Path, dst: Path, force_copy=False): shutil.copyfile(str(src), str(dst)) else: - def link_or_copy_file(src: Path, dst: Path): - os.symlink(str(src), str(dst)) + def link_or_copy_file(src: Path, dst: Path, force_copy=False): + if force_copy: + shutil.copyfile(str(src), str(dst)) + else: + os.symlink(str(src), str(dst)) class Watcher(object): def __init__(self, count: int) -> None: diff --git a/testsuite/tests/backpack/reexport/bkpreex03.stderr b/testsuite/tests/backpack/reexport/bkpreex03.stderr index 7d900da7d2..0fc295c018 100644 --- a/testsuite/tests/backpack/reexport/bkpreex03.stderr +++ b/testsuite/tests/backpack/reexport/bkpreex03.stderr @@ -2,4 +2,4 @@ [1 of 4] Compiling M1 ( p/M1.hs, nothing ) [2 of 4] Compiling M2 ( p/M2.hs, nothing ) [3 of 4] Compiling A[sig] ( p/A.hsig, nothing ) - [4 of 4] Compiling A[sig] ( p/A.hsig, nothing ) + [4 of 4] Compiling A[sig] ( p/A.hsig, nothing ) [M2 added] diff --git a/testsuite/tests/backpack/reexport/bkpreex04.stderr b/testsuite/tests/backpack/reexport/bkpreex04.stderr index a21cf89027..83c42910d6 100644 --- a/testsuite/tests/backpack/reexport/bkpreex04.stderr +++ b/testsuite/tests/backpack/reexport/bkpreex04.stderr @@ -1,4 +1,4 @@ [1 of 1] Processing p [1 of 3] Compiling A[sig] ( p/A.hsig, nothing ) [2 of 3] Compiling B[sig] ( p/B.hsig, nothing ) - [3 of 3] Compiling A[sig] ( p/A.hsig, nothing ) + [3 of 3] Compiling A[sig] ( p/A.hsig, nothing ) [B added] diff --git a/testsuite/tests/determinism/determ002/determ002.stdout b/testsuite/tests/determinism/determ002/determ002.stdout index 60c2bc368d..c9b56f14dc 100644 --- a/testsuite/tests/determinism/determ002/determ002.stdout +++ b/testsuite/tests/determinism/determ002/determ002.stdout @@ -1,2 +1,2 @@ [1 of 1] Compiling A ( A.hs, A.o ) -[1 of 1] Compiling A ( A.hs, A.o ) +[1 of 1] Compiling A ( A.hs, A.o ) [Missing object file] diff --git a/testsuite/tests/determinism/determ005/determ005.stdout b/testsuite/tests/determinism/determ005/determ005.stdout index 60c2bc368d..c9b56f14dc 100644 --- a/testsuite/tests/determinism/determ005/determ005.stdout +++ b/testsuite/tests/determinism/determ005/determ005.stdout @@ -1,2 +1,2 @@ [1 of 1] Compiling A ( A.hs, A.o ) -[1 of 1] Compiling A ( A.hs, A.o ) +[1 of 1] Compiling A ( A.hs, A.o ) [Missing object file] diff --git a/testsuite/tests/determinism/determ006/determ006.stdout b/testsuite/tests/determinism/determ006/determ006.stdout index 138d4023c5..d238fdd391 100644 --- a/testsuite/tests/determinism/determ006/determ006.stdout +++ b/testsuite/tests/determinism/determ006/determ006.stdout @@ -1,2 +1,2 @@ [1 of 1] Compiling Roman ( spec-inline-determ.hs, spec-inline-determ.o ) -[1 of 1] Compiling Roman ( spec-inline-determ.hs, spec-inline-determ.o ) +[1 of 1] Compiling Roman ( spec-inline-determ.hs, spec-inline-determ.o ) [Missing object file] diff --git a/testsuite/tests/driver/Makefile b/testsuite/tests/driver/Makefile index 84601a3512..0242b1aed4 100644 --- a/testsuite/tests/driver/Makefile +++ b/testsuite/tests/driver/Makefile @@ -679,3 +679,9 @@ T14452: T17786: # N.B. Check for the presence of caret diagnostics. "$(TEST_HC)" $(TEST_HC_OPTS) -v "$(shell cygpath -w -a T17786.hs)" 2>&1 | grep --quiet '3 |' + +.PHONY: OneShotTH +OneShotTH: + "$(TEST_HC)" $(TEST_HC_OPTS) -c OneShotTH.hs + # The module should *not* be recompiled + "$(TEST_HC)" $(TEST_HC_OPTS) -c OneShotTH.hs diff --git a/testsuite/tests/driver/OneShotTH.hs b/testsuite/tests/driver/OneShotTH.hs new file mode 100644 index 0000000000..4338e24527 --- /dev/null +++ b/testsuite/tests/driver/OneShotTH.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module OneShotTH where + +main = $([| print () |]) diff --git a/testsuite/tests/driver/OneShotTH.stdout b/testsuite/tests/driver/OneShotTH.stdout new file mode 100644 index 0000000000..ae02c1f7a8 --- /dev/null +++ b/testsuite/tests/driver/OneShotTH.stdout @@ -0,0 +1 @@ +compilation IS NOT required diff --git a/testsuite/tests/driver/T16511/B.hs b/testsuite/tests/driver/T16511/B.hs new file mode 100644 index 0000000000..f290969805 --- /dev/null +++ b/testsuite/tests/driver/T16511/B.hs @@ -0,0 +1,4 @@ +module B (name) where + +name :: String +name = "Samantha" diff --git a/testsuite/tests/driver/T16511/C.hs b/testsuite/tests/driver/T16511/C.hs index 34283b3701..4db28b6731 100644 --- a/testsuite/tests/driver/T16511/C.hs +++ b/testsuite/tests/driver/T16511/C.hs @@ -1,4 +1,4 @@ module C where name :: String -name = "Samantha" +name = "SamanthaC" diff --git a/testsuite/tests/driver/T16511/T16511.stdout b/testsuite/tests/driver/T16511/T16511.stdout index c54cfe1f12..de74e6bbf8 100644 --- a/testsuite/tests/driver/T16511/T16511.stdout +++ b/testsuite/tests/driver/T16511/T16511.stdout @@ -1,6 +1,6 @@ Hello Samantha Hello -Samantha +SamanthaC Hello Samantha diff --git a/testsuite/tests/driver/T16608/T16608_1.stdout b/testsuite/tests/driver/T16608/T16608_1.stdout index 05c44cb5a8..f925d67b8c 100644 --- a/testsuite/tests/driver/T16608/T16608_1.stdout +++ b/testsuite/tests/driver/T16608/T16608_1.stdout @@ -2,6 +2,6 @@ [2 of 2] Compiling Main ( T16608_1.hs, T16608_1.o ) Linking T16608_1 ... 41 -[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) +[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) [Source file changed] Linking T16608_1 ... 42 diff --git a/testsuite/tests/driver/T16608/T16608_2.stdout b/testsuite/tests/driver/T16608/T16608_2.stdout index 9ca19a6dba..af2de7e698 100644 --- a/testsuite/tests/driver/T16608/T16608_2.stdout +++ b/testsuite/tests/driver/T16608/T16608_2.stdout @@ -2,6 +2,6 @@ [2 of 2] Compiling Main ( T16608_2.hs, T16608_2.o ) Linking T16608_2 ... 41 -[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) +[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) [Source file changed] Linking T16608_2 ... 42 diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index 3b4162c95d..1c64f9905a 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -289,3 +289,4 @@ test('T17143', exit_code(1), run_command, ['{compiler} T17143.hs -S -fno-code']) test('T17786', unless(opsys('mingw32'), skip), makefile_test, []) test('T18369', normal, compile, ['-O']) test('FullGHCVersion', normal, compile_and_run, ['-package ghc-boot']) +test('OneShotTH', normal, makefile_test, []) diff --git a/testsuite/tests/driver/recomp-boot/recomp-boot.stdout b/testsuite/tests/driver/recomp-boot/recomp-boot.stdout index 77f5a1794a..5c122e2e34 100644 --- a/testsuite/tests/driver/recomp-boot/recomp-boot.stdout +++ b/testsuite/tests/driver/recomp-boot/recomp-boot.stdout @@ -2,5 +2,5 @@ [2 of 3] Compiling B ( B.hs, B.o ) [3 of 3] Compiling A ( A.hs, A.o ) [1 of 4] Compiling C[boot] ( C.hs-boot, C.o-boot ) -[3 of 4] Compiling B ( B.hs, B.o ) +[3 of 4] Compiling B ( B.hs, B.o ) [Source file changed] [4 of 4] Compiling A ( A.hs, A.o ) [B changed] diff --git a/testsuite/tests/driver/recomp-boot2/recomp-boot2.stdout b/testsuite/tests/driver/recomp-boot2/recomp-boot2.stdout index aec38b5f06..cac737564c 100644 --- a/testsuite/tests/driver/recomp-boot2/recomp-boot2.stdout +++ b/testsuite/tests/driver/recomp-boot2/recomp-boot2.stdout @@ -4,7 +4,7 @@ [4 of 5] Compiling M ( M.hs, M.o ) [5 of 5] Compiling Top ( Top.hs, Top.o ) [1 of 6] Compiling C[boot] ( C.hs-boot, C.o-boot ) -[3 of 6] Compiling B ( B.hs, B.o ) +[3 of 6] Compiling B ( B.hs, B.o ) [Source file changed] [4 of 6] Compiling A ( A.hs, A.o ) [B changed] [5 of 6] Compiling M ( M.hs, M.o ) [A changed] [6 of 6] Compiling Top ( Top.hs, Top.o ) [M changed] diff --git a/testsuite/tests/driver/recomp004/Makefile b/testsuite/tests/driver/recomp004/Makefile index 4ad51d8f60..52489dcf57 100644 --- a/testsuite/tests/driver/recomp004/Makefile +++ b/testsuite/tests/driver/recomp004/Makefile @@ -19,7 +19,7 @@ recomp004: $(CP) c2.c c.c '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -c c.c -o c.o # Hack to make sure c.o is really newer - touch -t 01010000 MainX.hs MainX.hi MainX.o c.c $(EXECUTABLE) + touch -t 01010000 MainX.hi MainX.o c.c $(EXECUTABLE) '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make MainX.hs c.o -o $(EXECUTABLE) ./$(EXECUTABLE) diff --git a/testsuite/tests/driver/recomp005/recomp005.stdout b/testsuite/tests/driver/recomp005/recomp005.stdout index 6e2581ed04..0726b49f9a 100644 --- a/testsuite/tests/driver/recomp005/recomp005.stdout +++ b/testsuite/tests/driver/recomp005/recomp005.stdout @@ -3,6 +3,6 @@ [3 of 5] Compiling C ( C.hs, C.o ) [4 of 5] Compiling D ( D.hs, D.o ) [5 of 5] Compiling E ( E.hs, E.o ) -[3 of 5] Compiling C ( C.hs, C.o ) +[3 of 5] Compiling C ( C.hs, C.o ) [Source file changed] [4 of 5] Compiling D ( D.hs, D.o ) [C changed] [5 of 5] Compiling E ( E.hs, E.o ) [D changed] diff --git a/testsuite/tests/driver/recomp006/recomp006.stdout b/testsuite/tests/driver/recomp006/recomp006.stdout index 499b06f08b..0de9d4d334 100644 --- a/testsuite/tests/driver/recomp006/recomp006.stdout +++ b/testsuite/tests/driver/recomp006/recomp006.stdout @@ -1,2 +1,2 @@ -[1 of 2] Compiling B ( B.hs, B.o ) +[1 of 2] Compiling B ( B.hs, B.o ) [Source file changed] [2 of 2] Compiling A ( A.hs, A.o ) [B changed] diff --git a/testsuite/tests/driver/recomp007/recomp007.stdout b/testsuite/tests/driver/recomp007/recomp007.stdout index 51b9a2a30c..1160663b4d 100644 --- a/testsuite/tests/driver/recomp007/recomp007.stdout +++ b/testsuite/tests/driver/recomp007/recomp007.stdout @@ -1,6 +1,6 @@ "1.0" Preprocessing executable 'test' for b-1.0.. Building executable 'test' for b-1.0.. -[1 of 2] Compiling B ( B.hs, dist/build/test/test-tmp/B.o ) [A changed] +[1 of 2] Compiling B ( B.hs, dist/build/test/test-tmp/B.o ) [A package changed] Linking dist/build/test/test ... "2.0" diff --git a/testsuite/tests/driver/recomp013/recomp013.stdout b/testsuite/tests/driver/recomp013/recomp013.stdout index 0a5aef7356..2720bb501f 100644 --- a/testsuite/tests/driver/recomp013/recomp013.stdout +++ b/testsuite/tests/driver/recomp013/recomp013.stdout @@ -3,5 +3,5 @@ first run [2 of 3] Compiling B ( B.hs, B.o ) [3 of 3] Compiling C ( C.hs, C.o ) second run -[2 of 3] Compiling B ( B.hs, B.o ) +[2 of 3] Compiling B ( B.hs, B.o ) [Source file changed] [3 of 3] Compiling C ( C.hs, C.o ) [B changed] diff --git a/testsuite/tests/driver/recomp016/recomp016.stdout b/testsuite/tests/driver/recomp016/recomp016.stdout index eb6c6fce42..1114de90aa 100644 --- a/testsuite/tests/driver/recomp016/recomp016.stdout +++ b/testsuite/tests/driver/recomp016/recomp016.stdout @@ -6,7 +6,7 @@ first run [5 of 5] Compiling E ( E.hs, E.o ) second run [1 of 5] Compiling A2 ( A2.hs, A2.o ) -[2 of 5] Compiling B ( B.hs, B.o ) +[2 of 5] Compiling B ( B.hs, B.o ) [Source file changed] [3 of 5] Compiling C ( C.hs, C.o ) [B changed] [4 of 5] Compiling D ( D.hs, D.o ) [C changed] [5 of 5] Compiling E ( E.hs, E.o ) [B changed] diff --git a/testsuite/tests/driver/recomp017/Makefile b/testsuite/tests/driver/recomp017/Makefile index 6a2f92a875..4b1bdda191 100644 --- a/testsuite/tests/driver/recomp017/Makefile +++ b/testsuite/tests/driver/recomp017/Makefile @@ -16,6 +16,5 @@ recomp017: clean # A simple 'cp' would overwrite the original file, # pointed to by the symlink mv -f C2.hs C.hs - touch C.hs echo 'second run' ! '$(TEST_HC)' $(TEST_HC_OPTS) --make E.hs diff --git a/testsuite/tests/driver/recomp019/recomp019.stdout b/testsuite/tests/driver/recomp019/recomp019.stdout index f1e4cd4d73..413dad2e0f 100644 --- a/testsuite/tests/driver/recomp019/recomp019.stdout +++ b/testsuite/tests/driver/recomp019/recomp019.stdout @@ -4,8 +4,8 @@ first run [3 of 3] Compiling Main ( Main.hs, Main.o ) Linking Main ... 5 -[1 of 1] Compiling B ( B.hs, nothing ) +[1 of 1] Compiling B ( B.hs, nothing ) [Source file changed] second run -[2 of 3] Compiling B ( B.hs, B.o ) +[1 of 3] Compiling B ( B.hs, B.o ) [Missing object file] Linking Main ... 15 diff --git a/testsuite/tests/driver/recomp16885/M.hs b/testsuite/tests/driver/recomp16885/M.hs new file mode 100644 index 0000000000..180dff6a79 --- /dev/null +++ b/testsuite/tests/driver/recomp16885/M.hs @@ -0,0 +1,2 @@ +module M where +import M1 diff --git a/testsuite/tests/driver/recomp16885/M1.hs b/testsuite/tests/driver/recomp16885/M1.hs new file mode 100644 index 0000000000..f9c1cb5a46 --- /dev/null +++ b/testsuite/tests/driver/recomp16885/M1.hs @@ -0,0 +1,4 @@ +module M1 where + +import M2 + diff --git a/testsuite/tests/driver/recomp16885/M2A.hs b/testsuite/tests/driver/recomp16885/M2A.hs new file mode 100644 index 0000000000..a99090730d --- /dev/null +++ b/testsuite/tests/driver/recomp16885/M2A.hs @@ -0,0 +1 @@ +module M2 where diff --git a/testsuite/tests/driver/recomp16885/M2B.hs b/testsuite/tests/driver/recomp16885/M2B.hs new file mode 100644 index 0000000000..bdd17a4922 --- /dev/null +++ b/testsuite/tests/driver/recomp16885/M2B.hs @@ -0,0 +1,2 @@ +module M2 where +import M3 diff --git a/testsuite/tests/driver/recomp16885/M3.hs b/testsuite/tests/driver/recomp16885/M3.hs new file mode 100644 index 0000000000..44866309ad --- /dev/null +++ b/testsuite/tests/driver/recomp16885/M3.hs @@ -0,0 +1 @@ +module M3 where diff --git a/testsuite/tests/driver/recomp16885/Makefile b/testsuite/tests/driver/recomp16885/Makefile new file mode 100644 index 0000000000..baa2c9e6c7 --- /dev/null +++ b/testsuite/tests/driver/recomp16885/Makefile @@ -0,0 +1,12 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# Recompilation tests + +recomp16885: + cp M2A.hs M2.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --make M.hs + sleep 1 + cp M2B.hs M2.hs + -'$(TEST_HC)' $(TEST_HC_OPTS) --make M.hs diff --git a/testsuite/tests/driver/recomp16885/all.T b/testsuite/tests/driver/recomp16885/all.T new file mode 100644 index 0000000000..b9821f9b42 --- /dev/null +++ b/testsuite/tests/driver/recomp16885/all.T @@ -0,0 +1,3 @@ +test('recomp16885', [extra_files(['M2A.hs', 'M.hs', 'M1.hs', 'M2B.hs', 'M3.hs']), + when(fast(), skip)], + makefile_test, []) diff --git a/testsuite/tests/driver/recomp16885/recomp16885.stdout b/testsuite/tests/driver/recomp16885/recomp16885.stdout new file mode 100644 index 0000000000..506b99c6ac --- /dev/null +++ b/testsuite/tests/driver/recomp16885/recomp16885.stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling M2 ( M2.hs, M2.o ) +[2 of 3] Compiling M1 ( M1.hs, M1.o ) +[3 of 3] Compiling M ( M.hs, M.o ) +[1 of 4] Compiling M3 ( M3.hs, M3.o ) +[2 of 4] Compiling M2 ( M2.hs, M2.o ) [Source file changed] diff --git a/testsuite/tests/driver/recompChangedPackage/Main.hs b/testsuite/tests/driver/recompChangedPackage/Main.hs new file mode 100644 index 0000000000..abdd92d83f --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import PLib +import QLib + +main = print [q] diff --git a/testsuite/tests/driver/recompChangedPackage/Makefile b/testsuite/tests/driver/recompChangedPackage/Makefile new file mode 100644 index 0000000000..ecbf49ec03 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/Makefile @@ -0,0 +1,37 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP='$(PWD)/Setup' -v0 +CONFIGURE=$(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS))' --package-db='$(PWD)/tmp.d' --prefix='$(PWD)/inst' $(VANILLA) $(PROF) $(DYN) + +recompChangedPackage: + '$(GHC_PKG)' init tmp.d + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup + # build q + (cd q; cp q.cabal1 q.cabal) + rm -rf q/dist + (cd q; $(CONFIGURE) --ipid "q-0.1") + (cd q; $(SETUP) build) + (cd q; $(SETUP) copy) + (cd q; $(SETUP) register) + + cp PLib1.hs PLib.hs + '$(TEST_HC)' -package-db tmp.d Main.hs + ./Main + + # Now add PLib to q.. Main should be recompiled + + $(GHC_PKG) --package-db tmp.d list + $(GHC_PKG) --package-db tmp.d unregister q-0.1.0.0 + rm PLib.hs + + (cd q; cp q.cabal2 q.cabal) + rm -rf q/dist + (cd q; $(CONFIGURE) --ipid "q-0.1") + (cd q; $(SETUP) build) + (cd q; $(SETUP) copy) + (cd q; $(SETUP) register) + + '$(TEST_HC)' -package-db tmp.d Main.hs + ./Main diff --git a/testsuite/tests/driver/recompChangedPackage/PLib1.hs b/testsuite/tests/driver/recompChangedPackage/PLib1.hs new file mode 100644 index 0000000000..439dcf1f43 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/PLib1.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE FlexibleInstances #-} +module PLib where + +p = 'p' + + diff --git a/testsuite/tests/driver/recompChangedPackage/Setup.hs b/testsuite/tests/driver/recompChangedPackage/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/recompChangedPackage/all.T b/testsuite/tests/driver/recompChangedPackage/all.T new file mode 100644 index 0000000000..8acd1655b9 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/all.T @@ -0,0 +1,19 @@ +if config.have_vanilla: + vanilla = '--enable-library-vanilla' +else: + vanilla = '--disable-library-vanilla' + +if config.have_profiling: + prof = '--enable-library-profiling' +else: + prof = '--disable-library-profiling' + +if not config.compiler_profiled and config.have_shared_libs: + dyn = '--enable-shared' +else: + dyn = '--disable-shared' + +test('recompChangedPackage', [extra_files(['q', 'Main.hs', 'Setup.hs', 'PLib1.hs']), + when(fast(), skip)], + run_command, + ['$MAKE -s --no-print-directory recompChangedPackage VANILLA=' + vanilla + ' PROF=' + prof + ' DYN=' + dyn]) diff --git a/testsuite/tests/driver/recompChangedPackage/q/CHANGELOG.md b/testsuite/tests/driver/recompChangedPackage/q/CHANGELOG.md new file mode 100644 index 0000000000..62632c5376 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/q/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for q + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/testsuite/tests/driver/recompChangedPackage/q/LICENSE b/testsuite/tests/driver/recompChangedPackage/q/LICENSE new file mode 100644 index 0000000000..bca70f3531 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/q/LICENSE @@ -0,0 +1 @@ +q diff --git a/testsuite/tests/driver/recompChangedPackage/q/Main.hs b/testsuite/tests/driver/recompChangedPackage/q/Main.hs new file mode 100644 index 0000000000..b566f91285 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/q/Main.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Lib + +main = print $(p) diff --git a/testsuite/tests/driver/recompChangedPackage/q/PLib.hs b/testsuite/tests/driver/recompChangedPackage/q/PLib.hs new file mode 100644 index 0000000000..ee009a196d --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/q/PLib.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE FlexibleInstances #-} +module PLib where + +p = 'e' + +instance {-# OVERLAPPING #-} Show [Char] where + show _ = "empty" diff --git a/testsuite/tests/driver/recompChangedPackage/q/QLib.hs b/testsuite/tests/driver/recompChangedPackage/q/QLib.hs new file mode 100644 index 0000000000..b98aa33300 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/q/QLib.hs @@ -0,0 +1,3 @@ +module QLib where + +q = 'q' diff --git a/testsuite/tests/driver/recompChangedPackage/q/Setup.hs b/testsuite/tests/driver/recompChangedPackage/q/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/q/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/recompChangedPackage/q/q.cabal b/testsuite/tests/driver/recompChangedPackage/q/q.cabal new file mode 100644 index 0000000000..f9f1e871cb --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/q/q.cabal @@ -0,0 +1,25 @@ +cabal-version: >=1.10 +-- Initial package description 'q.cabal' generated by 'cabal init'. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: q +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: QLib PLib + -- other-modules: + -- other-extensions: + build-depends: base >=4 && <5 + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/testsuite/tests/driver/recompChangedPackage/q/q.cabal1 b/testsuite/tests/driver/recompChangedPackage/q/q.cabal1 new file mode 100644 index 0000000000..01c41cd9d0 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/q/q.cabal1 @@ -0,0 +1,25 @@ +cabal-version: >=1.10 +-- Initial package description 'q.cabal' generated by 'cabal init'. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: q +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: QLib + -- other-modules: + -- other-extensions: + build-depends: base >=4 && <5 + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/testsuite/tests/driver/recompChangedPackage/q/q.cabal2 b/testsuite/tests/driver/recompChangedPackage/q/q.cabal2 new file mode 100644 index 0000000000..f9f1e871cb --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/q/q.cabal2 @@ -0,0 +1,25 @@ +cabal-version: >=1.10 +-- Initial package description 'q.cabal' generated by 'cabal init'. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: q +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: QLib PLib + -- other-modules: + -- other-extensions: + build-depends: base >=4 && <5 + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/testsuite/tests/driver/recompChangedPackage/recompChangedPackage.stdout b/testsuite/tests/driver/recompChangedPackage/recompChangedPackage.stdout new file mode 100644 index 0000000000..86d6324225 --- /dev/null +++ b/testsuite/tests/driver/recompChangedPackage/recompChangedPackage.stdout @@ -0,0 +1,10 @@ +[1 of 2] Compiling PLib ( PLib.hs, PLib.o ) +[2 of 2] Compiling Main ( Main.hs, Main.o ) +Linking Main ... +"q" +tmp.d + q-0.1.0.0 + +[1 of 1] Compiling Main ( Main.hs, Main.o ) [PLib removed] +Linking Main ... +empty diff --git a/testsuite/tests/driver/recompHash/A.hs b/testsuite/tests/driver/recompHash/A.hs new file mode 100644 index 0000000000..905110c8cf --- /dev/null +++ b/testsuite/tests/driver/recompHash/A.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module A where + +import B + +main = print 0 diff --git a/testsuite/tests/driver/recompHash/B.hs b/testsuite/tests/driver/recompHash/B.hs new file mode 100644 index 0000000000..7b1456b488 --- /dev/null +++ b/testsuite/tests/driver/recompHash/B.hs @@ -0,0 +1,3 @@ +module B where + +c = print 0 diff --git a/testsuite/tests/driver/recompHash/Makefile b/testsuite/tests/driver/recompHash/Makefile new file mode 100644 index 0000000000..6155169cba --- /dev/null +++ b/testsuite/tests/driver/recompHash/Makefile @@ -0,0 +1,17 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# Recompilation tests + +clean: + rm -f *.o* + rm -f *.dyn_o* + rm -f *.hi* + +# Touching a file should not cause recompilation + +recompHash: clean + '$(TEST_HC)' $(TEST_HC_OPTS) --make A.hs -fhide-source-paths + touch B.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --make A.hs -fhide-source-paths diff --git a/testsuite/tests/driver/recompHash/all.T b/testsuite/tests/driver/recompHash/all.T new file mode 100644 index 0000000000..ab0814b62b --- /dev/null +++ b/testsuite/tests/driver/recompHash/all.T @@ -0,0 +1,3 @@ +test('recompHash', [extra_files(['A.hs', 'B.hs']), + when(fast(), skip)], + makefile_test, []) diff --git a/testsuite/tests/driver/recompHash/recompHash.stdout b/testsuite/tests/driver/recompHash/recompHash.stdout new file mode 100644 index 0000000000..2c8a019066 --- /dev/null +++ b/testsuite/tests/driver/recompHash/recompHash.stdout @@ -0,0 +1,2 @@ +[1 of 2] Compiling B +[2 of 2] Compiling A diff --git a/testsuite/tests/driver/recompNoTH/A.hs b/testsuite/tests/driver/recompNoTH/A.hs new file mode 100644 index 0000000000..905110c8cf --- /dev/null +++ b/testsuite/tests/driver/recompNoTH/A.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module A where + +import B + +main = print 0 diff --git a/testsuite/tests/driver/recompNoTH/B1.hs b/testsuite/tests/driver/recompNoTH/B1.hs new file mode 100644 index 0000000000..7b1456b488 --- /dev/null +++ b/testsuite/tests/driver/recompNoTH/B1.hs @@ -0,0 +1,3 @@ +module B where + +c = print 0 diff --git a/testsuite/tests/driver/recompNoTH/B2.hs b/testsuite/tests/driver/recompNoTH/B2.hs new file mode 100644 index 0000000000..c7f392c91a --- /dev/null +++ b/testsuite/tests/driver/recompNoTH/B2.hs @@ -0,0 +1,3 @@ +module B where + +c = print 1 diff --git a/testsuite/tests/driver/recompNoTH/Makefile b/testsuite/tests/driver/recompNoTH/Makefile new file mode 100644 index 0000000000..113af9f204 --- /dev/null +++ b/testsuite/tests/driver/recompNoTH/Makefile @@ -0,0 +1,19 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# Recompilation tests + +clean: + rm -f *.o* + rm -f *.dyn_o* + rm -f *.hi* + +# If the source changes, but not the ABI, then only B should be recompiled. + +recompNoTH: clean + '$(CP)' B1.hs B.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --make A.hs -fhide-source-paths + '$(CP)' B2.hs B.hs + # Should print that only B has been recompiled. + '$(TEST_HC)' $(TEST_HC_OPTS) --make A.hs -fhide-source-paths diff --git a/testsuite/tests/driver/recompNoTH/all.T b/testsuite/tests/driver/recompNoTH/all.T new file mode 100644 index 0000000000..db66a0af41 --- /dev/null +++ b/testsuite/tests/driver/recompNoTH/all.T @@ -0,0 +1,3 @@ +test('recompNoTH', [extra_files(['A.hs', 'B1.hs', 'B2.hs' ]), + when(fast(), skip)], + makefile_test, []) diff --git a/testsuite/tests/driver/recompNoTH/recompNoTH.stdout b/testsuite/tests/driver/recompNoTH/recompNoTH.stdout new file mode 100644 index 0000000000..39bfe897f0 --- /dev/null +++ b/testsuite/tests/driver/recompNoTH/recompNoTH.stdout @@ -0,0 +1,3 @@ +[1 of 2] Compiling B +[2 of 2] Compiling A +[1 of 2] Compiling B [Source file changed] diff --git a/testsuite/tests/driver/recompPluginPackage/Makefile b/testsuite/tests/driver/recompPluginPackage/Makefile new file mode 100644 index 0000000000..1748c86481 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/Makefile @@ -0,0 +1,30 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP='$(PWD)/Setup' -v0 +CONFIGURE=$(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS))' --package-db='$(PWD)/tmp.d' --prefix='$(PWD)/inst' $(VANILLA) $(PROF) $(DYN) + +recompPluginPackage: + '$(GHC_PKG)' init tmp.d + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup + # build p + cp p/Lib1.hs p/Lib.hs + rm -rf p/dist + (cd p; $(CONFIGURE) --ipid "p-0.1") + (cd p; $(SETUP) build) + (cd p; $(SETUP) copy) + (cd p; $(SETUP) register) + # build q + rm -rf q/dist + (cd q; $(CONFIGURE) --ipid "q-0.1") + (cd q; $(SETUP) build) + (cd q; $(SETUP) copy) + (cd q; $(SETUP) register) + cp p/Lib2.hs p/Lib.hs + (cd p; $(SETUP) build) + (cd p; $(SETUP) copy) + (cd p; $(SETUP) register) + (cd q; $(SETUP) build) + (cd q; $(SETUP) copy) + (cd q; $(SETUP) register) diff --git a/testsuite/tests/driver/recompPluginPackage/README.md b/testsuite/tests/driver/recompPluginPackage/README.md new file mode 100644 index 0000000000..45d4b1d817 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/README.md @@ -0,0 +1,9 @@ +Modifying the definition of `p` in `Lib.hs` does not cause `q` to be recompiled. + +``` +> cabal new-run q +0 +-- Change p = [| 1 |] +> cabal new-run q +-- Prints 1.. used to print 0 +1 diff --git a/testsuite/tests/driver/recompPluginPackage/Setup.hs b/testsuite/tests/driver/recompPluginPackage/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/recompPluginPackage/all.T b/testsuite/tests/driver/recompPluginPackage/all.T new file mode 100644 index 0000000000..ea6cce4baa --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/all.T @@ -0,0 +1,20 @@ +if config.have_vanilla: + vanilla = '--enable-library-vanilla' +else: + vanilla = '--disable-library-vanilla' + +if config.have_profiling: + prof = '--enable-library-profiling' +else: + prof = '--disable-library-profiling' + +if not config.compiler_profiled and config.have_shared_libs: + dyn = '--enable-shared' +else: + dyn = '--disable-shared' + +test('recompPluginPackage', [extra_files(['p', 'q', 'Setup.hs']), + when(opsys('mingw32'), fragile(16405)), + when(fast(), skip)], + run_command, + ['$MAKE -s --no-print-directory recompPluginPackage VANILLA=' + vanilla + ' PROF=' + prof + ' DYN=' + dyn]) diff --git a/testsuite/tests/driver/recompPluginPackage/cabal.project b/testsuite/tests/driver/recompPluginPackage/cabal.project new file mode 100644 index 0000000000..838e7f9a75 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/cabal.project @@ -0,0 +1,2 @@ +packages: p q + diff --git a/testsuite/tests/driver/recompPluginPackage/p/CHANGELOG.md b/testsuite/tests/driver/recompPluginPackage/p/CHANGELOG.md new file mode 100644 index 0000000000..9ede8b27d4 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/p/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for p + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/testsuite/tests/driver/recompPluginPackage/p/LICENSE b/testsuite/tests/driver/recompPluginPackage/p/LICENSE new file mode 100644 index 0000000000..05bef1a55a --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/p/LICENSE @@ -0,0 +1 @@ +L diff --git a/testsuite/tests/driver/recompPluginPackage/p/Lib1.hs b/testsuite/tests/driver/recompPluginPackage/p/Lib1.hs new file mode 100644 index 0000000000..942c536874 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/p/Lib1.hs @@ -0,0 +1,5 @@ +module Lib where + +{-# NOINLINE p #-} +p = 1 + diff --git a/testsuite/tests/driver/recompPluginPackage/p/Lib2.hs b/testsuite/tests/driver/recompPluginPackage/p/Lib2.hs new file mode 100644 index 0000000000..259ae46461 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/p/Lib2.hs @@ -0,0 +1,5 @@ +module Lib where + +{-# NOINLINE p #-} +p = 2 + diff --git a/testsuite/tests/driver/recompPluginPackage/p/Main.hs b/testsuite/tests/driver/recompPluginPackage/p/Main.hs new file mode 100644 index 0000000000..65ae4a05d5 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/p/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/testsuite/tests/driver/recompPluginPackage/p/Setup.hs b/testsuite/tests/driver/recompPluginPackage/p/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/p/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/recompPluginPackage/p/p.cabal b/testsuite/tests/driver/recompPluginPackage/p/p.cabal new file mode 100644 index 0000000000..ebf8f3dc5c --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/p/p.cabal @@ -0,0 +1,24 @@ +cabal-version: >=1.10 +-- Initial package description 'p.cabal' generated by 'cabal init'. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: p +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: Lib + -- other-extensions: + build-depends: base >=4.14 && < 5 + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/testsuite/tests/driver/recompPluginPackage/q/CHANGELOG.md b/testsuite/tests/driver/recompPluginPackage/q/CHANGELOG.md new file mode 100644 index 0000000000..62632c5376 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/q/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for q + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/testsuite/tests/driver/recompPluginPackage/q/LICENSE b/testsuite/tests/driver/recompPluginPackage/q/LICENSE new file mode 100644 index 0000000000..bca70f3531 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/q/LICENSE @@ -0,0 +1 @@ +q diff --git a/testsuite/tests/driver/recompPluginPackage/q/Main.hs b/testsuite/tests/driver/recompPluginPackage/q/Main.hs new file mode 100644 index 0000000000..60fd0cc6f5 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/q/Main.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -fplugin=Plugin #-} +module Main where + +main = print () diff --git a/testsuite/tests/driver/recompPluginPackage/q/Plugin.hs b/testsuite/tests/driver/recompPluginPackage/q/Plugin.hs new file mode 100644 index 0000000000..32ce1bd96b --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/q/Plugin.hs @@ -0,0 +1,15 @@ +module Plugin where + +import GHC.Plugins +import Lib + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + , pluginRecompile = purePlugin + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + liftIO (print p) + return todo diff --git a/testsuite/tests/driver/recompPluginPackage/q/Setup.hs b/testsuite/tests/driver/recompPluginPackage/q/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/q/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/recompPluginPackage/q/q.cabal b/testsuite/tests/driver/recompPluginPackage/q/q.cabal new file mode 100644 index 0000000000..8216113fce --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/q/q.cabal @@ -0,0 +1,26 @@ +cabal-version: >=1.10 +-- Initial package description 'q.cabal' generated by 'cabal init'. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: q +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +executable q + main-is: Main.hs + other-modules: Plugin + -- other-extensions: + build-depends: base >=4.14 && <5, p, ghc + -- hs-source-dirs: + ghc-options: -dynamic-too + default-language: Haskell2010 diff --git a/testsuite/tests/driver/recompPluginPackage/recompPluginPackage.stderr-mingw32 b/testsuite/tests/driver/recompPluginPackage/recompPluginPackage.stderr-mingw32 new file mode 100644 index 0000000000..46497c6618 --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/recompPluginPackage.stderr-mingw32 @@ -0,0 +1,12 @@ + +when making flags consistent: warning: + -dynamic-too is not supported on Windows + +when making flags consistent: warning: + -dynamic-too is not supported on Windows + +when making flags consistent: warning: + -dynamic-too is not supported on Windows + +when making flags consistent: warning: + -dynamic-too is not supported on Windows diff --git a/testsuite/tests/driver/recompPluginPackage/recompPluginPackage.stdout b/testsuite/tests/driver/recompPluginPackage/recompPluginPackage.stdout new file mode 100644 index 0000000000..1191247b6d --- /dev/null +++ b/testsuite/tests/driver/recompPluginPackage/recompPluginPackage.stdout @@ -0,0 +1,2 @@ +1 +2 diff --git a/testsuite/tests/driver/recompTH/A.hs b/testsuite/tests/driver/recompTH/A.hs new file mode 100644 index 0000000000..df7dfdab91 --- /dev/null +++ b/testsuite/tests/driver/recompTH/A.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module A where + +import B + +main = $(b) diff --git a/testsuite/tests/driver/recompTH/B1.hs b/testsuite/tests/driver/recompTH/B1.hs new file mode 100644 index 0000000000..c57def3417 --- /dev/null +++ b/testsuite/tests/driver/recompTH/B1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module B where + +b = [| print 0 |] diff --git a/testsuite/tests/driver/recompTH/B2.hs b/testsuite/tests/driver/recompTH/B2.hs new file mode 100644 index 0000000000..99c3171111 --- /dev/null +++ b/testsuite/tests/driver/recompTH/B2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module B where + +b = [| print 1 |] diff --git a/testsuite/tests/driver/recompTH/Makefile b/testsuite/tests/driver/recompTH/Makefile new file mode 100644 index 0000000000..1ab14f8f9a --- /dev/null +++ b/testsuite/tests/driver/recompTH/Makefile @@ -0,0 +1,20 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# Recompilation tests + +clean: + rm -f *.o* + rm -f *.dyn_o* + rm -f *.hi* + +# Test that using a TH splice in a module causes recompilation when the *source* +# of a dependency changes. + +recompTH: clean + '$(CP)' B1.hs B.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --make A.hs -fhide-source-paths + '$(CP)' B2.hs B.hs + # Should print that A has been recompiled. + '$(TEST_HC)' $(TEST_HC_OPTS) --make A.hs -fhide-source-paths diff --git a/testsuite/tests/driver/recompTH/all.T b/testsuite/tests/driver/recompTH/all.T new file mode 100644 index 0000000000..be28961173 --- /dev/null +++ b/testsuite/tests/driver/recompTH/all.T @@ -0,0 +1,4 @@ +test('recompTH', [extra_files(['A.hs', 'B1.hs', 'B2.hs' ]), + when(fast(), skip) + , normalise_slashes], + makefile_test, []) diff --git a/testsuite/tests/driver/recompTH/recompTH.stdout b/testsuite/tests/driver/recompTH/recompTH.stdout new file mode 100644 index 0000000000..482191e1d5 --- /dev/null +++ b/testsuite/tests/driver/recompTH/recompTH.stdout @@ -0,0 +1,4 @@ +[1 of 2] Compiling B +[2 of 2] Compiling A +[1 of 2] Compiling B [Source file changed] +[2 of 2] Compiling A [B[TH] changed] diff --git a/testsuite/tests/driver/recompTHpackage/Makefile b/testsuite/tests/driver/recompTHpackage/Makefile new file mode 100644 index 0000000000..ed865b9cc2 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/Makefile @@ -0,0 +1,32 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP='$(PWD)/Setup' -v0 +CONFIGURE=$(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS))' --package-db='$(PWD)/tmp.d' --prefix='$(PWD)/inst' $(VANILLA) $(PROF) $(DYN) + +recompTHpackage: + '$(GHC_PKG)' init tmp.d + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup + # build p + cp p/Lib1.hs p/Lib.hs + rm -rf p/dist + (cd p; $(CONFIGURE) --ipid "p-0.1") + (cd p; $(SETUP) build) + (cd p; $(SETUP) copy) + (cd p; $(SETUP) register) + # build q + rm -rf q/dist + (cd q; $(CONFIGURE) --ipid "q-0.1") + (cd q; $(SETUP) build) + (cd q; $(SETUP) copy) + (cd q; $(SETUP) register) + ./inst/bin/q + cp p/Lib2.hs p/Lib.hs + (cd p; $(SETUP) build) + (cd p; $(SETUP) copy) + (cd p; $(SETUP) register) + (cd q; $(SETUP) build) + (cd q; $(SETUP) copy) + (cd q; $(SETUP) register) + ./inst/bin/q diff --git a/testsuite/tests/driver/recompTHpackage/README.md b/testsuite/tests/driver/recompTHpackage/README.md new file mode 100644 index 0000000000..8253a75272 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/README.md @@ -0,0 +1,9 @@ +Modifying the definition of `p` in `Lib.hs` does not cause `q` to be recompiled. + +``` +> cabal new-run q +0 +-- Change p = [| 1 |] +> cabal new-run q +-- BUG: Should be 1 +0 diff --git a/testsuite/tests/driver/recompTHpackage/Setup.hs b/testsuite/tests/driver/recompTHpackage/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/recompTHpackage/all.T b/testsuite/tests/driver/recompTHpackage/all.T new file mode 100644 index 0000000000..6e2826300c --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/all.T @@ -0,0 +1,19 @@ +if config.have_vanilla: + vanilla = '--enable-library-vanilla' +else: + vanilla = '--disable-library-vanilla' + +if config.have_profiling: + prof = '--enable-library-profiling' +else: + prof = '--disable-library-profiling' + +if not config.compiler_profiled and config.have_shared_libs: + dyn = '--enable-shared' +else: + dyn = '--disable-shared' + +test('recompTHpackage', [extra_files(['p', 'q', 'Setup.hs']), + when(fast(), skip)], + run_command, + ['$MAKE -s --no-print-directory recompTHpackage VANILLA=' + vanilla + ' PROF=' + prof + ' DYN=' + dyn]) diff --git a/testsuite/tests/driver/recompTHpackage/cabal.project b/testsuite/tests/driver/recompTHpackage/cabal.project new file mode 100644 index 0000000000..838e7f9a75 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/cabal.project @@ -0,0 +1,2 @@ +packages: p q + diff --git a/testsuite/tests/driver/recompTHpackage/p/CHANGELOG.md b/testsuite/tests/driver/recompTHpackage/p/CHANGELOG.md new file mode 100644 index 0000000000..9ede8b27d4 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/p/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for p + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/testsuite/tests/driver/recompTHpackage/p/LICENSE b/testsuite/tests/driver/recompTHpackage/p/LICENSE new file mode 100644 index 0000000000..05bef1a55a --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/p/LICENSE @@ -0,0 +1 @@ +L diff --git a/testsuite/tests/driver/recompTHpackage/p/Lib1.hs b/testsuite/tests/driver/recompTHpackage/p/Lib1.hs new file mode 100644 index 0000000000..f50e3a830c --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/p/Lib1.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module Lib where + +{-# NOINLINE p #-} +p = [| 1 |] + diff --git a/testsuite/tests/driver/recompTHpackage/p/Lib2.hs b/testsuite/tests/driver/recompTHpackage/p/Lib2.hs new file mode 100644 index 0000000000..8bbee29e74 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/p/Lib2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module Lib where + +{-# NOINLINE p #-} +p = [| 2 |] + diff --git a/testsuite/tests/driver/recompTHpackage/p/Main.hs b/testsuite/tests/driver/recompTHpackage/p/Main.hs new file mode 100644 index 0000000000..65ae4a05d5 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/p/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/testsuite/tests/driver/recompTHpackage/p/Setup.hs b/testsuite/tests/driver/recompTHpackage/p/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/p/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/recompTHpackage/p/p.cabal b/testsuite/tests/driver/recompTHpackage/p/p.cabal new file mode 100644 index 0000000000..3ae74c4b13 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/p/p.cabal @@ -0,0 +1,24 @@ +cabal-version: >=1.10 +-- Initial package description 'p.cabal' generated by 'cabal init'. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: p +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: Lib + -- other-extensions: + build-depends: base >=4.14 && < 5, template-haskell + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/testsuite/tests/driver/recompTHpackage/q/CHANGELOG.md b/testsuite/tests/driver/recompTHpackage/q/CHANGELOG.md new file mode 100644 index 0000000000..62632c5376 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/q/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for q + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/testsuite/tests/driver/recompTHpackage/q/LICENSE b/testsuite/tests/driver/recompTHpackage/q/LICENSE new file mode 100644 index 0000000000..bca70f3531 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/q/LICENSE @@ -0,0 +1 @@ +q diff --git a/testsuite/tests/driver/recompTHpackage/q/Main.hs b/testsuite/tests/driver/recompTHpackage/q/Main.hs new file mode 100644 index 0000000000..b566f91285 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/q/Main.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Lib + +main = print $(p) diff --git a/testsuite/tests/driver/recompTHpackage/q/Setup.hs b/testsuite/tests/driver/recompTHpackage/q/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/q/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/recompTHpackage/q/q.cabal b/testsuite/tests/driver/recompTHpackage/q/q.cabal new file mode 100644 index 0000000000..0537ef0d9b --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/q/q.cabal @@ -0,0 +1,25 @@ +cabal-version: >=1.10 +-- Initial package description 'q.cabal' generated by 'cabal init'. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: q +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +executable q + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.14 && <5, p + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/testsuite/tests/driver/recompTHpackage/recompTHpackage.stdout b/testsuite/tests/driver/recompTHpackage/recompTHpackage.stdout new file mode 100644 index 0000000000..1191247b6d --- /dev/null +++ b/testsuite/tests/driver/recompTHpackage/recompTHpackage.stdout @@ -0,0 +1,2 @@ +1 +2 diff --git a/testsuite/tests/driver/retc001/retc001.stdout b/testsuite/tests/driver/retc001/retc001.stdout index 381850d9a4..e5d374608e 100644 --- a/testsuite/tests/driver/retc001/retc001.stdout +++ b/testsuite/tests/driver/retc001/retc001.stdout @@ -3,5 +3,5 @@ [3 of 3] Compiling Main ( C.hs, nothing ) Middle End -[2 of 3] Compiling B ( B.hs, nothing ) +[2 of 3] Compiling B ( B.hs, nothing ) [Source file changed] [3 of 3] Compiling Main ( C.hs, nothing ) [B changed] diff --git a/testsuite/tests/driver/th-new-test/A.hs b/testsuite/tests/driver/th-new-test/A.hs new file mode 100644 index 0000000000..700e87789d --- /dev/null +++ b/testsuite/tests/driver/th-new-test/A.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module A where + +import B + +a = print $(b) diff --git a/testsuite/tests/driver/th-new-test/B.hs b/testsuite/tests/driver/th-new-test/B.hs new file mode 100644 index 0000000000..c59d95459f --- /dev/null +++ b/testsuite/tests/driver/th-new-test/B.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TemplateHaskell #-} +module B where + +b = [| 'b' |] diff --git a/testsuite/tests/driver/th-new-test/B1.hs b/testsuite/tests/driver/th-new-test/B1.hs new file mode 100644 index 0000000000..6723d49b15 --- /dev/null +++ b/testsuite/tests/driver/th-new-test/B1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TemplateHaskell #-} +module B where + +b = [| "b1" |] diff --git a/testsuite/tests/driver/th-new-test/C.hs b/testsuite/tests/driver/th-new-test/C.hs new file mode 100644 index 0000000000..eed7c6556d --- /dev/null +++ b/testsuite/tests/driver/th-new-test/C.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module C where + +import D + +c = print $(d) diff --git a/testsuite/tests/driver/th-new-test/D.hs b/testsuite/tests/driver/th-new-test/D.hs new file mode 100644 index 0000000000..0dcddfde2d --- /dev/null +++ b/testsuite/tests/driver/th-new-test/D.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module D where + +d = [| 'd' |] diff --git a/testsuite/tests/driver/th-new-test/D1.hs b/testsuite/tests/driver/th-new-test/D1.hs new file mode 100644 index 0000000000..1db6c126e4 --- /dev/null +++ b/testsuite/tests/driver/th-new-test/D1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module D where + +d = [| "d1" |] diff --git a/testsuite/tests/driver/th-new-test/Main.hs b/testsuite/tests/driver/th-new-test/Main.hs new file mode 100644 index 0000000000..0b8ce305b8 --- /dev/null +++ b/testsuite/tests/driver/th-new-test/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import A +import C + +main = a >> c diff --git a/testsuite/tests/driver/th-new-test/Makefile b/testsuite/tests/driver/th-new-test/Makefile new file mode 100644 index 0000000000..63b10db4aa --- /dev/null +++ b/testsuite/tests/driver/th-new-test/Makefile @@ -0,0 +1,29 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# Recompilation tests + +clean: + rm -f *.o* + rm -f *.dyn_o* + rm -f *.hi* + rm -f *.dyn_hi* + +th-new-test: clean + '$(TEST_HC)' $(TEST_HC_OPTS) --make Main.hs -fhide-source-paths + # No recompilation + '$(TEST_HC)' $(TEST_HC_OPTS) --make Main.hs -fhide-source-paths + cp B.hs B_O.hs + cp B1.hs B.hs + # Recompile just B and A + '$(TEST_HC)' $(TEST_HC_OPTS) --make Main.hs -fhide-source-paths + cp D.hs D_O.hs + cp D1.hs D.hs + # Recompile just D and C + '$(TEST_HC)' $(TEST_HC_OPTS) --make Main.hs -fhide-source-paths + cp D_O.hs D.hs + cp B_O.hs B.hs + # Recompile A B C D + '$(TEST_HC)' $(TEST_HC_OPTS) --make Main.hs -fhide-source-paths + diff --git a/testsuite/tests/driver/th-new-test/all.T b/testsuite/tests/driver/th-new-test/all.T new file mode 100644 index 0000000000..8a98d69919 --- /dev/null +++ b/testsuite/tests/driver/th-new-test/all.T @@ -0,0 +1,4 @@ +test('th-new-test', [extra_files(['A.hs', 'B.hs', 'C.hs', 'D.hs', 'B1.hs', 'D1.hs', 'Main.hs']), + when(fast(), skip) + , normalise_slashes], + makefile_test, []) diff --git a/testsuite/tests/driver/th-new-test/th-new-test.stdout b/testsuite/tests/driver/th-new-test/th-new-test.stdout new file mode 100644 index 0000000000..7f31ce608f --- /dev/null +++ b/testsuite/tests/driver/th-new-test/th-new-test.stdout @@ -0,0 +1,17 @@ +[1 of 5] Compiling B +[2 of 5] Compiling A +[3 of 5] Compiling D +[4 of 5] Compiling C +[5 of 5] Compiling Main +Linking Main ... +[1 of 5] Compiling B [Source file changed] +[2 of 5] Compiling A [B[TH] changed] +Linking Main ... +[3 of 5] Compiling D [Source file changed] +[4 of 5] Compiling C [D[TH] changed] +Linking Main ... +[1 of 5] Compiling B [Source file changed] +[2 of 5] Compiling A [B[TH] changed] +[3 of 5] Compiling D [Source file changed] +[4 of 5] Compiling C [D[TH] changed] +Linking Main ... diff --git a/testsuite/tests/gadt/Makefile b/testsuite/tests/gadt/Makefile index db4e0521a4..aa5271d3fd 100644 --- a/testsuite/tests/gadt/Makefile +++ b/testsuite/tests/gadt/Makefile @@ -19,9 +19,7 @@ T7321: gadt23: $(RM) gadt23 gadt23.hi gadt23.o Gadt23_AST.hi Gadt23_AST.o '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make gadt23.hs - # We want to "touch gadt23.hs" really, but we then have issues with - # everything happening in the same second so the touch having no - # effect. Thus make gadt23.hi/o older instead. - touch -t 01010000 gadt23.hi gadt23.o + # Append a blank line to gadt23.hs to trigger a recompile + echo >> gadt23.hs '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make gadt23.hs diff --git a/testsuite/tests/gadt/all.T b/testsuite/tests/gadt/all.T index 225d8e8650..91ba74b722 100644 --- a/testsuite/tests/gadt/all.T +++ b/testsuite/tests/gadt/all.T @@ -27,7 +27,7 @@ test('gadt20', normal, compile, ['']) test('gadt21', normal, compile_fail, ['']) test('gadt22', normal, compile, ['']) -test('gadt23', [extra_files(['Gadt23_AST.hs'])], makefile_test, ['gadt23']) +test('gadt23', [copy_files, extra_files(['Gadt23_AST.hs'])], makefile_test, ['gadt23']) test('gadt24', normal, compile, ['']) diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index 3d929c8c9d..392c318768 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -30,8 +30,7 @@ main = do p <- parseModule modSum t <- typecheckModule p d <- desugarModule t - l <- loadModule d - let ts=typecheckedSource l + let ts=typecheckedSource d -- liftIO (putStr (showSDocDebug (ppr ts))) let fs=filterBag isDataCon ts return $ not $ isEmptyBag fs diff --git a/testsuite/tests/ghci.debugger/scripts/break022/all.T b/testsuite/tests/ghci.debugger/scripts/break022/all.T index a4acedea38..87fb764f69 100644 --- a/testsuite/tests/ghci.debugger/scripts/break022/all.T +++ b/testsuite/tests/ghci.debugger/scripts/break022/all.T @@ -1,3 +1,3 @@ setTestOpts(extra_run_opts('-ignore-dot-ghci')) -test('break022', [extra_files(['A1.hs', 'B.hs', 'B.hs-boot', 'C.hs'])], ghci_script, ['break022.script']) +test('break022', [extra_files(['../../../ghci/shell.hs', 'A1.hs', 'B.hs', 'B.hs-boot', 'C.hs'])], ghci_script, ['break022.script']) diff --git a/testsuite/tests/ghci.debugger/scripts/break022/break022.script b/testsuite/tests/ghci.debugger/scripts/break022/break022.script index 33780a1408..42cc8979ea 100644 --- a/testsuite/tests/ghci.debugger/scripts/break022/break022.script +++ b/testsuite/tests/ghci.debugger/scripts/break022/break022.script @@ -1,3 +1,5 @@ +:l shell.hs +:def shell (\s -> do shell s; return "") -- We have this structure of modules: @@ -10,9 +12,9 @@ -- But first we touch A, and reload. B.boot will be reloaded, but not B, which will end up with an empty modbreaks. When we :step into B, ghci will die with an out of bounds access in B's break array. -- The effect we want is B.boot being reloaded while B is not. -:! cp A1.hs A.hs +:shell cp A1.hs A.hs :l C -:! touch A.hs +:shell echo >> A.hs :r :break a a () diff --git a/testsuite/tests/ghci.debugger/scripts/break023/all.T b/testsuite/tests/ghci.debugger/scripts/break023/all.T index 7a5dd1b3cb..794c4c4a38 100644 --- a/testsuite/tests/ghci.debugger/scripts/break023/all.T +++ b/testsuite/tests/ghci.debugger/scripts/break023/all.T @@ -1,3 +1,3 @@ setTestOpts(extra_run_opts('-ignore-dot-ghci')) -test('break023', [extra_files(['A1.hs', 'B.hs', 'B.hs-boot', 'C.hs'])], ghci_script, ['break023.script']) +test('break023', [extra_files(['../../../ghci/shell.hs', 'A1.hs', 'B.hs', 'B.hs-boot', 'C.hs'])], ghci_script, ['break023.script']) diff --git a/testsuite/tests/ghci.debugger/scripts/break023/break023.script b/testsuite/tests/ghci.debugger/scripts/break023/break023.script index a7a0916863..080dcd2c24 100644 --- a/testsuite/tests/ghci.debugger/scripts/break023/break023.script +++ b/testsuite/tests/ghci.debugger/scripts/break023/break023.script @@ -1,3 +1,5 @@ +:l shell.hs +:def shell (\s -> do shell s; return "") -- We have this structure of modules: @@ -10,9 +12,9 @@ -- But first we touch A, and reload. B.boot will be reloaded, but not B, which will end up with an empty modbreaks. We can no longer set a breakpoint in B.b -- The effect we want is B.boot being reloaded while B is not. -:! cp A1.hs A.hs +:shell cp A1.hs A.hs :l C :break b -- it works ok at this point -:! touch A.hs +:shell echo >> A.hs :r :break b -- it does not work anymore diff --git a/testsuite/tests/ghci/prog001/prog001.script b/testsuite/tests/ghci/prog001/prog001.script index 3d0e973c57..f08b8b0155 100644 --- a/testsuite/tests/ghci/prog001/prog001.script +++ b/testsuite/tests/ghci/prog001/prog001.script @@ -17,9 +17,8 @@ -- make sure `main' works main --- touch a module + recompile -:shell sleep 1 -:shell touch C.hs +-- change a module + recompile +:shell echo >> C.hs :reload -- make sure `main' still works diff --git a/testsuite/tests/ghci/prog005/prog005.T b/testsuite/tests/ghci/prog005/prog005.T index c9ca987c87..5327832b71 100644 --- a/testsuite/tests/ghci/prog005/prog005.T +++ b/testsuite/tests/ghci/prog005/prog005.T @@ -1 +1 @@ -test('prog005', [extra_files(['A1.hs', 'B.hs'])], ghci_script, ['prog005.script']) +test('prog005', [extra_files(['../shell.hs', 'A1.hs', 'B.hs'])], ghci_script, ['prog005.script']) diff --git a/testsuite/tests/ghci/prog005/prog005.script b/testsuite/tests/ghci/prog005/prog005.script index d720edbd0f..44b8f8dd31 100644 --- a/testsuite/tests/ghci/prog005/prog005.script +++ b/testsuite/tests/ghci/prog005/prog005.script @@ -1,14 +1,16 @@ +:l shell.hs +:def shell (\s -> do shell s; return "") + :unset +s :unset +t -:!cp A1.hs A.hs +:shell cp A1.hs A.hs :load B -- eval something that isn't exported from B z -:!sleep 1 -:!touch A.hs +:shell echo >> A.hs :reload -- A should be recompiled, B will be skipped. We should still have diff --git a/testsuite/tests/ghci/recompTHghci/A.hs b/testsuite/tests/ghci/recompTHghci/A.hs new file mode 100644 index 0000000000..df7dfdab91 --- /dev/null +++ b/testsuite/tests/ghci/recompTHghci/A.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module A where + +import B + +main = $(b) diff --git a/testsuite/tests/ghci/recompTHghci/B1.hs b/testsuite/tests/ghci/recompTHghci/B1.hs new file mode 100644 index 0000000000..c57def3417 --- /dev/null +++ b/testsuite/tests/ghci/recompTHghci/B1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module B where + +b = [| print 0 |] diff --git a/testsuite/tests/ghci/recompTHghci/B2.hs b/testsuite/tests/ghci/recompTHghci/B2.hs new file mode 100644 index 0000000000..99c3171111 --- /dev/null +++ b/testsuite/tests/ghci/recompTHghci/B2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module B where + +b = [| print 1 |] diff --git a/testsuite/tests/ghci/recompTHghci/Makefile b/testsuite/tests/ghci/recompTHghci/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghci/recompTHghci/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghci/recompTHghci/all.T b/testsuite/tests/ghci/recompTHghci/all.T new file mode 100644 index 0000000000..033712aef0 --- /dev/null +++ b/testsuite/tests/ghci/recompTHghci/all.T @@ -0,0 +1,6 @@ +test('recompTHghci', + [extra_files(['../shell.hs', 'A.hs', 'B1.hs', 'B2.hs']), + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp, + unless(opsys('mingw32') or not config.have_RTS_linker, extra_ways(['ghci-ext']))], + ghci_script, ['recompTHghci.script']) diff --git a/testsuite/tests/ghci/recompTHghci/recompTHghci.script b/testsuite/tests/ghci/recompTHghci/recompTHghci.script new file mode 100644 index 0000000000..fc61500a09 --- /dev/null +++ b/testsuite/tests/ghci/recompTHghci/recompTHghci.script @@ -0,0 +1,24 @@ +:unset +s + +:l shell.hs +:def shell (\s -> do shell s; return "") + +-- first, tidy up: +:shell rm -f *.hi *.o *~ +:shell cp B1.hs B.hs + +-- load the program (all interpreted) +:load A.hs + +-- reloading should do nothing +:reload + +-- make sure `main' works +main + +-- change a module + recompile +:shell cp B2.hs B.hs +:reload + +-- make sure `main' still works +main diff --git a/testsuite/tests/ghci/recompTHghci/recompTHghci.stdout b/testsuite/tests/ghci/recompTHghci/recompTHghci.stdout new file mode 100644 index 0000000000..0d66ea1aee --- /dev/null +++ b/testsuite/tests/ghci/recompTHghci/recompTHghci.stdout @@ -0,0 +1,2 @@ +0 +1 diff --git a/testsuite/tests/ghci/scripts/Defer03.hs b/testsuite/tests/ghci/scripts/Defer03_before.hs index b0f65fbade..b0f65fbade 100644 --- a/testsuite/tests/ghci/scripts/Defer03.hs +++ b/testsuite/tests/ghci/scripts/Defer03_before.hs diff --git a/testsuite/tests/ghci/scripts/T17669.stdout b/testsuite/tests/ghci/scripts/T17669.stdout index a62c5ee82e..4d3d1718ba 100644 --- a/testsuite/tests/ghci/scripts/T17669.stdout +++ b/testsuite/tests/ghci/scripts/T17669.stdout @@ -1,6 +1,6 @@ [1 of 1] Compiling T17669 ( T17669.hs, T17669.o ) Ok, one module loaded. this -[1 of 1] Compiling T17669 ( T17669.hs, T17669.o ) +[1 of 1] Compiling T17669 ( T17669.hs, T17669.o ) [Source file changed] Ok, one module loaded. that diff --git a/testsuite/tests/ghci/scripts/T1914.script b/testsuite/tests/ghci/scripts/T1914.script index 5a74350341..85bd74a63c 100644 --- a/testsuite/tests/ghci/scripts/T1914.script +++ b/testsuite/tests/ghci/scripts/T1914.script @@ -1,16 +1,15 @@ +:l shell.hs +:def shell (\s -> do shell s; return "") + :set -v1 System.IO.writeFile "T1914A.hs" "module T1914A where { import T1914B; }" System.IO.writeFile "T1914B.hs" "module T1914B where { type T = Int; }" --- hack: avoid the need for sleep by using specific timestamps: -:! touch -t 01010000 T1914A.hs -:! touch -t 01010000 T1914B.hs :load T1914A System.IO.writeFile "T1914A.hs" "module T1914A where { import T1914B; oops }" -:! touch -t 01010001 T1914A.hs :reload -- T1914B should still be loaded :module *T1914B System.IO.writeFile "T1914A.hs" "module T1914A where { import T1914B; }" -:! touch -t 01010002 T1914A.hs +:shell echo >> T1914A.hs :reload -- should not have to reload T1914B diff --git a/testsuite/tests/ghci/scripts/T1914.stdout b/testsuite/tests/ghci/scripts/T1914.stdout index 6612564354..dfeeeca727 100644 --- a/testsuite/tests/ghci/scripts/T1914.stdout +++ b/testsuite/tests/ghci/scripts/T1914.stdout @@ -1,7 +1,7 @@ [1 of 2] Compiling T1914B ( T1914B.hs, interpreted ) [2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) Ok, two modules loaded. -[2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) +[2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) [Source file changed] Failed, one module loaded. [2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) Ok, two modules loaded. diff --git a/testsuite/tests/ghci/scripts/T8042.stdout b/testsuite/tests/ghci/scripts/T8042.stdout index fe2720d35d..9a06c41189 100644 --- a/testsuite/tests/ghci/scripts/T8042.stdout +++ b/testsuite/tests/ghci/scripts/T8042.stdout @@ -2,7 +2,7 @@ [2 of 3] Compiling T8042C ( T8042C.hs, interpreted ) [3 of 3] Compiling T8042A ( T8042A.hs, interpreted ) Ok, three modules loaded. -[3 of 3] Compiling T8042A ( T8042A.hs, T8042A.o ) +[3 of 3] Compiling T8042A ( T8042A.hs, T8042A.o ) [Source file changed] Ok, three modules loaded. [2 of 3] Compiling T8042C ( T8042C.hs, interpreted ) [3 of 3] Compiling T8042A ( T8042A.hs, interpreted ) diff --git a/testsuite/tests/ghci/scripts/T8353.script b/testsuite/tests/ghci/scripts/T8353.script index d93fb6e4cb..7e68cee238 100644 --- a/testsuite/tests/ghci/scripts/T8353.script +++ b/testsuite/tests/ghci/scripts/T8353.script @@ -1,3 +1,9 @@ +:l shell.hs +:def shell (\s -> do shell s; return "") +:l + +:shell cp Defer03_before.hs Defer03.hs + -- Test :load! and :reload! -- main is independent of functions with type errors and thus @@ -11,12 +17,14 @@ -- succeeds again to load module :reload! --- also succeeds, because the module has not been touched since load +-- also succeeds, because the module has not been changed since load :reload --- now, after touching, reloading should fail -:! touch Defer03.hs +-- now, after modifying, reloading should fail +:shell echo "-- an extra comment so that the hash changes" >> Defer03.hs :reload -- using the deferred version of reload, loading should succeed again :reload! + +:shell rm Defer03.hs diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index 10c224b46b..e4fae93e6b 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -102,7 +102,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('ghci063', [extra_files(['../shell.hs'])], ghci_script, ['ghci063.script']) test('ghci064', normal, ghci_script, ['ghci064.script']) test('ghci065', [extra_hc_opts("-haddock")], ghci_script, ['ghci065.script']) test('ghci066', normal, ghci_script, ['ghci066.script']) @@ -110,7 +110,7 @@ test('T2452', [extra_hc_opts("-fno-implicit-import-qualified")], ghci_script, ['T2452.script']) test('T2766', normal, ghci_script, ['T2766.script']) -test('T1914', [], ghci_script, ['T1914.script']) +test('T1914', [extra_files(['../shell.hs'])], ghci_script, ['T1914.script']) test('T2182ghci', normal, ghci_script, ['T2182ghci.script']) test('T2182ghci2', [extra_hc_opts("-XNoImplicitPrelude")], ghci_script, ['T2182ghci2.script']) @@ -142,10 +142,10 @@ test('T5979', normalise_version("transformers")], ghci_script, ['T5979.script']) test('T5975a', - pre_cmd('touch föøbàr1.hs'), + pre_cmd('echo >> föøbàr1.hs'), ghci_script, ['T5975a.script']) test('T5975b', - [pre_cmd('touch föøbàr2.hs'), extra_hc_opts('föøbàr2.hs')], + [pre_cmd('echo >> föøbàr2.hs'), extra_hc_opts('föøbàr2.hs')], ghci_script, ['T5975b.script']) test('T6027ghci', normal, ghci_script, ['T6027ghci.script']) @@ -181,7 +181,7 @@ test('T8172', when(opsys('mingw32'), normalise_drive_letter), ghci_script, ['T8172.script']) test('T8215', normal, ghci_script, ['T8215.script']) test('T8305', normal, ghci_script, ['T8305.script']) -test('T8353', extra_files(['Defer03.hs']), ghci_script, ['T8353.script']) +test('T8353', extra_files(['../shell.hs', 'Defer03_before.hs']), ghci_script, ['T8353.script']) test('T8357', normal, ghci_script, ['T8357.script']) test('T8383', normal, ghci_script, ['T8383.script']) test('T8469', normal, ghci_script, ['T8469.script']) diff --git a/testsuite/tests/ghci/scripts/ghci063.script b/testsuite/tests/ghci/scripts/ghci063.script index 6cba37b9ab..5b74e1841d 100644 --- a/testsuite/tests/ghci/scripts/ghci063.script +++ b/testsuite/tests/ghci/scripts/ghci063.script @@ -1,5 +1,9 @@ -:! echo module A where {} >A.hs -:! echo module B where { import A } >B.hs +:l shell.hs +:def shell (\s -> do shell s; return "") +:l + +:shell echo module A where {} >A.hs +:shell echo module B where { import A } >B.hs -- Workaround for #16201. We use "touch -r" to set modification -- timestamps, which leads to precision loss on Darwin. For example, @@ -11,20 +15,21 @@ -- by restoring its old timestamp, as we cannot faithfully restore all digits. -- -- The solution is to nullify the insignificant digits before the first load. -:! touch -r B.hs B.hs +:shell touch -r B.hs 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 +-- changing its timestamp. A :reload should look at the contents of the +-- file, because the hash has changed. Note that this test previously tested +-- for the opposite behaviour, but was changed as a result of #19439 / #16495. +:shell cp B.hs B.hs-copy +:shell touch -r B.hs B.hs-copy +:shell echo "*** INVALID ***" >B.hs +:shell touch -r B.hs-copy B.hs :reload -- Put the original file back, now it should work -:! cp B.hs-copy B.hs +:shell cp B.hs-copy B.hs :reload diff --git a/testsuite/tests/ghci/scripts/ghci063.stderr b/testsuite/tests/ghci/scripts/ghci063.stderr new file mode 100644 index 0000000000..cc357499a2 --- /dev/null +++ b/testsuite/tests/ghci/scripts/ghci063.stderr @@ -0,0 +1,2 @@ + +B.hs:1:1: error: parse error on input ‘***’ diff --git a/testsuite/tests/perf/compiler/Makefile b/testsuite/tests/perf/compiler/Makefile index 66597883b6..20f5704450 100644 --- a/testsuite/tests/perf/compiler/Makefile +++ b/testsuite/tests/perf/compiler/Makefile @@ -12,3 +12,7 @@ T11068: '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T11068a.hs '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T11068b.hs -'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T11068.hs -ddump-simpl | grep 'Generic' + +MultiModulesRecomp: + ./genMultiLayerModules + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 MultiLayerModules.hs diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 04d03e0568..eadf2ff920 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -276,6 +276,22 @@ test('MultiLayerModules', multimod_compile, ['MultiLayerModules', '-v0']) +# MultiLayerModules flip flops by 2.5%, depending on the +# number of modules within GHC (#19293). Just widen the +# acceptance window until we figured out how to fix it. +test('MultiLayerModulesRecomp', + [ collect_compiler_stats('bytes allocated',3), + pre_cmd('$MAKE -s --no-print-directory MultiModulesRecomp'), + extra_files(['genMultiLayerModules']), + compile_timeout_multiplier(5) + # this is _a lot_ + # but this test has been failing every now and then, + # especially on i386. Let's just give it some room + # to complete successfully reliably everywhere. + ], + multimod_compile, + ['MultiLayerModules', '-v0']) + test('ManyConstructors', [ collect_compiler_stats('bytes allocated',2), pre_cmd('./genManyConstructors'), diff --git a/testsuite/tests/perf/space_leaks/T4029.script b/testsuite/tests/perf/space_leaks/T4029.script index 91135c9477..f2faa4fd1a 100644 --- a/testsuite/tests/perf/space_leaks/T4029.script +++ b/testsuite/tests/perf/space_leaks/T4029.script @@ -102,203 +102,203 @@ -- Load a minimalist module and reload it 99 times :load T4029a -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -:! touch T4029a.hs +:! echo >> T4029a.hs :reload -- Load a more complex module 10 times @@ -315,21 +315,21 @@ -- Load a more complex module and reload it 9 times :load T4029b -:! touch T4029b.hs +:! echo >> T4029b.hs :reload -:! touch T4029b.hs +:! echo >> T4029b.hs :reload -:! touch T4029b.hs +:! echo >> T4029b.hs :reload -:! touch T4029b.hs +:! echo >> T4029b.hs :reload -:! touch T4029b.hs +:! echo >> T4029b.hs :reload -:! touch T4029b.hs +:! echo >> T4029b.hs :reload -:! touch T4029b.hs +:! echo >> T4029b.hs :reload -:! touch T4029b.hs +:! echo >> T4029b.hs :reload -:! touch T4029b.hs +:! echo >> T4029b.hs :reload diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T index deb5ea38e4..f6638555c9 100644 --- a/testsuite/tests/perf/space_leaks/all.T +++ b/testsuite/tests/perf/space_leaks/all.T @@ -31,7 +31,7 @@ test('T4018', compile_and_run, ['-fno-state-hack']) test('T4029', - [collect_runtime_residency(10), + [copy_files, collect_runtime_residency(10), ], ghci_script, ['T4029.script']) diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T index e02681d7c0..12aba63022 100644 --- a/testsuite/tests/plugins/all.T +++ b/testsuite/tests/plugins/all.T @@ -225,3 +225,5 @@ test('test-hooks-plugin', ], compile_and_run, ['-package-db hooks-plugin/pkg.hooks-plugin/local.package.conf '+ config.plugin_way_flags]) + +test('plugins-ghci', [extra_files(['HomePackagePlugin.hs']), only_ways(['ghci'])], compile_and_run, ['-package ghc']) diff --git a/testsuite/tests/plugins/plugins-ghci.hs b/testsuite/tests/plugins/plugins-ghci.hs new file mode 100644 index 0000000000..57efb9e7e7 --- /dev/null +++ b/testsuite/tests/plugins/plugins-ghci.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -fplugin=HomePackagePlugin #-} +module Main where + +main = print () diff --git a/testsuite/tests/plugins/plugins-ghci.stdout b/testsuite/tests/plugins/plugins-ghci.stdout new file mode 100644 index 0000000000..6a452c185a --- /dev/null +++ b/testsuite/tests/plugins/plugins-ghci.stdout @@ -0,0 +1 @@ +() diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index 63eabff460..b67efa2039 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -33,6 +33,7 @@ import GHC.Parser.Lexer import GHC.Data.FastString import GHC.Types.SrcLoc + -- --------------------------------------------------------------------- _tt :: IO () @@ -346,7 +347,7 @@ parseOneFile libdir fileName = let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream _ <- setSessionDynFlags dflags2 hsc_env <- getSession - emodSum <- liftIO $ summariseFile hsc_env [] fileName Nothing True Nothing + emodSum <- liftIO $ summariseFile hsc_env [] fileName Nothing Nothing case emsModSummary <$> emodSum of Left _err -> error "parseOneFile" Right modSum -> do diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs index 80828874f6..d064431ec4 100644 --- a/utils/check-ppr/Main.hs +++ b/utils/check-ppr/Main.hs @@ -85,7 +85,7 @@ parseOneFile libdir fileName = do let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream _ <- setSessionDynFlags dflags2 hsc_env <- getSession - ms <- liftIO $ summariseFile hsc_env [] fileName Nothing True Nothing + ms <- liftIO $ summariseFile hsc_env [] fileName Nothing Nothing case ms of Left _err -> error "parseOneFile" Right ems -> parseModule (emsModSummary ems) |