diff options
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 257 | ||||
| -rw-r--r-- | compiler/main/Hooks.hs | 5 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 310 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/driver/all.T | 2 |
5 files changed, 261 insertions, 320 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 9523e87942..02f3caf5c9 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -64,7 +64,6 @@ import MonadUtils import Platform import TcRnTypes import Hooks -import MkIface import Exception import Data.IORef ( readIORef ) @@ -133,173 +132,90 @@ compileOne' :: Maybe TcGblEnv compileOne' m_tc_result mHscMessage hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable source_modified0 - | HsBootMerge <- ms_hsc_src summary - = do -- Do a boot merge instead! For now, something very simple - output_fn <- getOutputFilename next_phase - Temporary basename dflags next_phase (Just location) - e <- genericHscMergeRequirement mHscMessage - hsc_env summary mb_old_iface (mod_index, nmods) - - case e of - -- TODO: dedup - Left iface -> - do details <- genModDetails hsc_env iface - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = maybe_old_linkable }) - Right (iface0, mb_old_hash) -> - case hsc_lang of - HscInterpreted -> - do (iface, _no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0 - details <- genModDetails hsc_env iface - -- Merges don't need to link in any bytecode, unlike - -- HsSrcFiles. - let linkable = LM (ms_hs_date summary) this_mod [] - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) - - HscNothing -> - do (iface, no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0 - details <- genModDetails hsc_env iface - when (gopt Opt_WriteInterface dflags) $ - hscWriteIface dflags iface no_change summary - let linkable = LM (ms_hs_date summary) this_mod [] - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) - _ -> - do (iface, no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0 - hscWriteIface dflags iface no_change summary - - -- #10660: Use the pipeline instead of calling - -- compileEmptyStub directly, so -dynamic-too gets - -- handled properly - let mod_name = ms_mod_name summary - _ <- runPipeline StopLn hsc_env - (output_fn, - Just (HscOut src_flavour - mod_name HscUpdateBootMerge)) - (Just basename) - Persistent - (Just location) - Nothing - - details <- genModDetails hsc_env iface - - o_time <- getModificationUTCTime object_filename - let linkable = - LM o_time this_mod [DotO object_filename] - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) - - | otherwise = do debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) - -- What file to generate the output into? - output_fn <- getOutputFilename next_phase - Temporary basename dflags next_phase (Just location) - - e <- genericHscCompileGetFrontendResult - always_do_basic_recompilation_check - m_tc_result mHscMessage - hsc_env summary source_modified mb_old_iface (mod_index, nmods) - - case e of - Left iface -> - do details <- genModDetails hsc_env iface - MASSERT(isJust maybe_old_linkable || isNoLink (ghcLink dflags)) - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = maybe_old_linkable }) - - Right (tc_result, mb_old_hash) -> - -- run the compiler - case hsc_lang of - HscInterpreted -> - case ms_hsc_src summary of - HsBootFile -> - do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Nothing }) - _ -> do guts0 <- hscDesugar hsc_env summary tc_result - guts <- hscSimplify hsc_env guts0 - (iface, _changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash - (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary - - stub_o <- case hasStub of - Nothing -> return [] - Just stub_c -> do - stub_o <- compileStub hsc_env stub_c - return [DotO stub_o] - - let hs_unlinked = [BCOs comp_bc modBreaks] - unlinked_time = ms_hs_date summary - -- 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 - -- with the filesystem's clock. It's just as accurate: - -- if the source is modified, then the linkable will - -- be out of date. - let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_o) - - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) - HscNothing -> - do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash - when (gopt Opt_WriteInterface dflags) $ - hscWriteIface dflags iface changed summary - let linkable = if isHsBoot src_flavour - then Nothing - else Just (LM (ms_hs_date summary) this_mod []) - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = linkable }) - _ -> - case ms_hsc_src summary of - HsBootMerge -> panic "This driver can't handle it" - HsBootFile -> - do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash - hscWriteIface dflags iface changed summary - - touchObjectFile dflags object_filename - - return (HomeModInfo{ - hm_details = details, - hm_iface = iface, - hm_linkable = Nothing }) - - HsSrcFile -> - do guts0 <- hscDesugar hsc_env summary tc_result - guts <- hscSimplify hsc_env guts0 - (iface, changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash - hscWriteIface dflags iface changed summary - - -- We're in --make mode: finish the compilation pipeline. - let mod_name = ms_mod_name summary - _ <- runPipeline StopLn hsc_env - (output_fn, - Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) - (Just basename) - Persistent - (Just location) - Nothing - -- The object filename comes from the ModLocation - o_time <- getModificationUTCTime object_filename - let linkable = LM o_time this_mod [DotO object_filename] - - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) + (status, hmi0) <- hscIncrementalCompile + always_do_basic_recompilation_check + m_tc_result mHscMessage + hsc_env summary source_modified mb_old_iface (mod_index, nmods) + + case (status, hsc_lang) of + (HscUpToDate, _) -> + ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) ) + return hmi0 { hm_linkable = maybe_old_linkable } + (HscNotGeneratingCode, HscNothing) -> + let mb_linkable = if isHsBoot src_flavour + then Nothing + -- TODO: Questionable. + else Just (LM (ms_hs_date summary) this_mod []) + in return hmi0 { hm_linkable = mb_linkable } + (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode" + (_, HscNothing) -> panic "compileOne HscNothing" + (HscUpdateBoot, HscInterpreted) -> do + return hmi0 + (HscUpdateBoot, _) -> do + touchObjectFile dflags object_filename + return hmi0 + (HscUpdateBootMerge, HscInterpreted) -> + let linkable = LM (ms_hs_date summary) this_mod [] + in return hmi0 { hm_linkable = Just linkable } + (HscUpdateBootMerge, _) -> do + output_fn <- getOutputFilename next_phase + Temporary basename dflags next_phase (Just location) + + -- #10660: Use the pipeline instead of calling + -- compileEmptyStub directly, so -dynamic-too gets + -- handled properly + _ <- runPipeline StopLn hsc_env + (output_fn, + Just (HscOut src_flavour + mod_name HscUpdateBootMerge)) + (Just basename) + Persistent + (Just location) + Nothing + o_time <- getModificationUTCTime object_filename + let linkable = LM o_time this_mod [DotO object_filename] + return hmi0 { hm_linkable = Just linkable } + (HscRecomp cgguts summary, HscInterpreted) -> do + (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary + + stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env stub_c + return [DotO stub_o] + + let hs_unlinked = [BCOs comp_bc modBreaks] + unlinked_time = ms_hs_date summary + -- 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 + -- with the filesystem's clock. It's just as accurate: + -- if the source is modified, then the linkable will + -- be out of date. + let linkable = LM unlinked_time (ms_mod summary) + (hs_unlinked ++ stub_o) + return hmi0 { hm_linkable = Just linkable } + (HscRecomp cgguts summary, _) -> do + output_fn <- getOutputFilename next_phase + Temporary basename dflags next_phase (Just location) + -- We're in --make mode: finish the compilation pipeline. + _ <- runPipeline StopLn hsc_env + (output_fn, + Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) + (Just basename) + Persistent + (Just location) + Nothing + -- The object filename comes from the ModLocation + o_time <- getModificationUTCTime object_filename + let linkable = LM o_time this_mod [DotO object_filename] + return hmi0 { hm_linkable = Just linkable } + where dflags0 = ms_hspp_opts summary - this_mod = ms_mod summary - src_flavour = ms_hsc_src summary location = ms_location summary input_fn = expectJust "compile:hs" (ml_hs_file location) input_fnpp = ms_hspp_file summary @@ -310,6 +226,13 @@ compileOne' m_tc_result mHscMessage isDynWay = any (== WayDyn) (ways dflags0) isProfWay = any (== WayProf) (ways dflags0) + + src_flavour = ms_hsc_src summary + this_mod = ms_mod summary + mod_name = ms_mod_name summary + next_phase = hscPostBackendPhase dflags src_flavour hsc_lang + object_filename = ml_obj_file location + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so -- the linker can correctly load the object files. @@ -329,15 +252,12 @@ compileOne' m_tc_result mHscMessage -- Figure out what lang we're generating hsc_lang = hscTarget dflags - -- ... and what the next phase should be - next_phase = hscPostBackendPhase dflags src_flavour hsc_lang -- -fforce-recomp should also work with --make force_recomp = gopt Opt_ForceRecomp dflags source_modified | force_recomp = SourceModified | otherwise = source_modified0 - object_filename = ml_obj_file location always_do_basic_recompilation_check = case hsc_lang of HscInterpreted -> True @@ -1087,8 +1007,9 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 ms_merge_imps = (False, []) } -- run the compiler! - result <- liftIO $ hscCompileOneShot hsc_env' - mod_summary source_unchanged + let msg hsc_env _ what _ = oneShotMsg hsc_env what + (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' + mod_summary source_unchanged Nothing (1,1) return (HscOut src_flavour mod_name result, panic "HscOut doesn't have an input filename") diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index f9339b1cef..f75214b4f4 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -14,7 +14,6 @@ module Hooks ( Hooks , tcForeignImportsHook , tcForeignExportsHook , hscFrontendHook - , hscCompileOneShotHook , hscCompileCoreExprHook , ghcPrimIfaceHook , runPhaseHook @@ -58,14 +57,12 @@ import Data.Maybe emptyHooks :: Hooks emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing data Hooks = Hooks { dsForeignsHook :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) , tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)) , tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)) - , hscFrontendHook :: Maybe (ModSummary -> Hsc TcGblEnv) - , hscCompileOneShotHook :: Maybe (HscEnv -> ModSummary -> SourceModified -> IO HscStatus) + , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue) , ghcPrimIfaceHook :: Maybe ModIface , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index e5c6ce14ec..f783a9a9bc 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -19,10 +19,11 @@ -- from here on in (although it has mutable components, for the -- caches). -- --- Warning messages are dealt with consistently throughout this API: --- during compilation warnings are collected, and before any function --- in @HscMain@ returns, the warnings are either printed, or turned --- into a real compialtion error if the @-Werror@ flag is enabled. +-- We use the Hsc monad to deal with warning messages consistently: +-- specifically, while executing within an Hsc monad, warnings are +-- collected. When a Hsc monad returns to an IO monad, the +-- warnings are printed, or compilation aborts if the @-Werror@ +-- flag is enabled. -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 -- @@ -36,12 +37,11 @@ module HscMain -- * Compiling complete source files , Messager, batchMsg , HscStatus (..) - , hscCompileOneShot + , hscIncrementalCompile , hscCompileCmmFile , hscCompileCore - , genericHscCompileGetFrontendResult - , genericHscMergeRequirement + , hscIncrementalFrontend , genModDetails , hscSimpleIface @@ -58,12 +58,14 @@ module HscMain , makeSimpleDetails , hscSimplify -- ToDo, shouldn't really export this + -- * Safe Haskell + , hscCheckSafe + , hscGetSafe + -- * Support for interactive evaluation , hscParseIdentifier , hscTcRcLookupName , hscTcRnGetInfo - , hscCheckSafe - , hscGetSafe #ifdef GHCI , hscIsGHCiMonad , hscGetModuleInterface @@ -513,73 +515,38 @@ This is the only thing that isn't caught by the type-system. type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO () --- | Analogous to 'genericHscCompileGetFrontendResult', this function --- calls 'hscMergeFrontEnd' if recompilation is necessary. It does --- not write out the resulting 'ModIface' (see 'compileOne'). --- TODO: maybe fold this 'genericHscCompileGetFrontendResult' into --- some higher-order function -genericHscMergeRequirement :: - Maybe Messager - -> HscEnv - -> ModSummary - -> Maybe ModIface -- Old interface, if available - -> (Int,Int) -- (i,n) = module i of n (for msgs) - -> IO (Either ModIface (ModIface, Maybe Fingerprint)) -genericHscMergeRequirement mHscMessage - hsc_env mod_summary mb_old_iface mod_index = do - let msg what = case mHscMessage of - Just hscMessage -> - hscMessage hsc_env mod_index what mod_summary - Nothing -> return () - - skip iface = do - msg UpToDate - return (Left iface) - - -- TODO: hook this - compile mb_old_hash reason = do - msg reason - r <- hscMergeFrontEnd hsc_env mod_summary - return $ Right (r, mb_old_hash) - - (recomp_reqd, mb_checked_iface) - <- {-# SCC "checkOldIface" #-} - checkOldIface hsc_env mod_summary - SourceUnmodified mb_old_iface - case mb_checked_iface of - Just iface | not (recompileRequired recomp_reqd) -> skip iface - _ -> compile (fmap mi_iface_hash mb_checked_iface) recomp_reqd - --- | This function runs 'genericHscFrontend' if recompilation is necessary. --- It does not write out the results of typechecking (see 'compileOne'). -genericHscCompileGetFrontendResult :: - Bool -- always do basic recompilation check? - -> Maybe TcGblEnv - -> Maybe Messager - -> HscEnv - -> ModSummary - -> SourceModified - -> Maybe ModIface -- Old interface, if available - -> (Int,Int) -- (i,n) = module i of n (for msgs) - -> IO (Either ModIface (TcGblEnv, Maybe Fingerprint)) - -genericHscCompileGetFrontendResult +-- | This function runs GHC's frontend with recompilation +-- avoidance. Specifically, it checks if recompilation is needed, +-- and if it is, it parses and typechecks the input module. +-- It does not write out the results of typechecking (See +-- compileOne and hscIncrementalCompile). +hscIncrementalFrontend :: Bool -- always do basic recompilation check? + -> Maybe TcGblEnv + -> Maybe Messager + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface, if available + -> (Int,Int) -- (i,n) = module i of n (for msgs) + -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)) + +hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result - mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index + mHscMessage mod_summary source_modified mb_old_iface mod_index = do + hsc_env <- getHscEnv let msg what = case mHscMessage of Just hscMessage -> hscMessage hsc_env mod_index what mod_summary Nothing -> return () skip iface = do - msg UpToDate + liftIO $ msg UpToDate return $ Left iface compile mb_old_hash reason = do - msg reason - tc_result <- runHsc hsc_env $ genericHscFrontend mod_summary - return $ Right (tc_result, mb_old_hash) + liftIO $ msg reason + result <- genericHscFrontend mod_summary + return $ Right (result, mb_old_hash) stable = case source_modified of SourceUnmodifiedAndStable -> True @@ -588,11 +555,11 @@ genericHscCompileGetFrontendResult case m_tc_result of Just tc_result | not always_do_basic_recompilation_check -> - return $ Right (tc_result, Nothing) + return $ Right (FrontendTypecheck tc_result, Nothing) _ -> do (recomp_reqd, mb_checked_iface) <- {-# SCC "checkOldIface" #-} - checkOldIface hsc_env mod_summary + liftIO $ checkOldIface hsc_env mod_summary source_modified mb_old_iface -- save the interface that comes back from checkOldIface. -- In one-shot mode we don't have the old iface until this @@ -624,101 +591,149 @@ genericHscCompileGetFrontendResult case m_tc_result of Nothing -> compile mb_old_hash recomp_reqd Just tc_result -> - return $ Right (tc_result, mb_old_hash) + return $ Right (FrontendTypecheck tc_result, mb_old_hash) -genericHscFrontend :: ModSummary -> Hsc TcGblEnv +genericHscFrontend :: ModSummary -> Hsc FrontendResult genericHscFrontend mod_summary = getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary) -genericHscFrontend' :: ModSummary -> Hsc TcGblEnv -genericHscFrontend' mod_summary = hscFileFrontEnd mod_summary +genericHscFrontend' :: ModSummary -> Hsc FrontendResult +genericHscFrontend' mod_summary + | ms_hsc_src mod_summary == HsBootMerge + = FrontendMerge `fmap` hscMergeFrontEnd mod_summary + | otherwise + = FrontendTypecheck `fmap` hscFileFrontEnd mod_summary -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- -hscCompileOneShot :: HscEnv - -> ModSummary - -> SourceModified - -> IO HscStatus -hscCompileOneShot env = - lookupHook hscCompileOneShotHook hscCompileOneShot' (hsc_dflags env) env - -- Compile Haskell/boot in OneShot mode. -hscCompileOneShot' :: HscEnv - -> ModSummary - -> SourceModified - -> IO HscStatus -hscCompileOneShot' hsc_env mod_summary src_changed +hscIncrementalCompile :: Bool + -> Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface + -> (Int,Int) + -- HomeModInfo does not contain linkable, since we haven't + -- code-genned yet + -> IO (HscStatus, HomeModInfo) +hscIncrementalCompile always_do_basic_recompilation_check m_tc_result + mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index = do -- One-shot mode needs a knot-tying mutable variable for interface -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. type_env_var <- newIORef emptyNameEnv let mod = ms_mod mod_summary - hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } + hsc_env = hsc_env'{ hsc_type_env_var = Just (mod, type_env_var) } - msg what = oneShotMsg hsc_env' what - - skip = do msg UpToDate - dumpIfaceStats hsc_env' - return HscUpToDate + -- NB: enter Hsc monad here so that we don't bail out early with + -- -Werror on typechecker warnings; we also want to run the desugarer + -- to get those warnings too. (But we'll always exit at that point + -- because the desugarer runs ioMsgMaybe.) + runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env - compile mb_old_hash reason = runHsc hsc_env' $ do - liftIO $ msg reason - tc_result <- genericHscFrontend mod_summary - guts0 <- hscDesugar' (ms_location mod_summary) tc_result - dflags <- getDynFlags + e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage + mod_summary source_modified mb_old_iface mod_index + case e of + Left iface -> do + details <- liftIO $ genModDetails hsc_env iface + return (HscUpToDate, HomeModInfo{ + hm_details = details, + hm_iface = iface, + hm_linkable = Nothing + }) + Right (result, mb_old_hash) -> do + (status, hmi, no_change) <- case result of + FrontendTypecheck tc_result -> + if hscTarget dflags /= HscNothing && + ms_hsc_src mod_summary == HsSrcFile + then finish hsc_env mod_summary tc_result mb_old_hash + else finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash + FrontendMerge raw_iface -> + finishMerge hsc_env mod_summary raw_iface mb_old_hash + liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary + return (status, hmi) + +-- Generates and writes out the final interface for an hs-boot merge. +finishMerge :: HscEnv + -> ModSummary + -> ModIface + -> Maybe Fingerprint + -> Hsc (HscStatus, HomeModInfo, Bool) +finishMerge hsc_env summary iface0 mb_old_hash = do + MASSERT( ms_hsc_src summary == HsBootMerge ) + (iface, changed) <- liftIO $ mkIfaceDirect hsc_env mb_old_hash iface0 + details <- liftIO $ genModDetails hsc_env iface + let dflags = hsc_dflags hsc_env + hsc_status = case hscTarget dflags of - HscNothing -> do - when (gopt Opt_WriteInterface dflags) $ liftIO $ do - (iface, changed, _details) <- hscSimpleIface hsc_env tc_result mb_old_hash - hscWriteIface dflags iface changed mod_summary - return HscNotGeneratingCode - _ -> - case ms_hsc_src mod_summary of - HsBootFile -> - do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash - liftIO $ hscWriteIface dflags iface changed mod_summary - return HscUpdateBoot - HsSrcFile -> - do guts <- hscSimplify' guts0 - (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash - liftIO $ hscWriteIface dflags iface changed mod_summary - return $ HscRecomp cgguts mod_summary - HsBootMerge -> panic "hscCompileOneShot HsBootMerge" - - -- XXX This is always False, because in one-shot mode the - -- concept of stability does not exist. The driver never - -- passes SourceUnmodifiedAndStable in here. - stable = case src_changed of - SourceUnmodifiedAndStable -> True - _ -> False - - (recomp_reqd, mb_checked_iface) - <- {-# SCC "checkOldIface" #-} - checkOldIface hsc_env' mod_summary src_changed Nothing - -- 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 mb_checked_iface - - 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. - if mi_used_th iface && not stable - then compile mb_old_hash (RecompBecause "TH") - else skip - _ -> - compile mb_old_hash recomp_reqd + HscNothing -> HscNotGeneratingCode + _ -> HscUpdateBootMerge + return (hsc_status, + HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = Nothing }, + changed) + +-- Generates and writes out the final interface for a typecheck. +finishTypecheckOnly :: HscEnv + -> ModSummary + -> TcGblEnv + -> Maybe Fingerprint + -> Hsc (HscStatus, HomeModInfo, Bool) +finishTypecheckOnly hsc_env summary tc_result mb_old_hash = do + let dflags = hsc_dflags hsc_env + MASSERT( hscTarget dflags == HscNothing || ms_hsc_src summary == HsBootFile ) + (iface, changed, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash + let hsc_status = + case (hscTarget dflags, ms_hsc_src summary) of + (HscNothing, _) -> HscNotGeneratingCode + (_, HsBootFile) -> HscUpdateBoot + _ -> panic "finishTypecheckOnly" + return (hsc_status, + HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = Nothing }, + changed) + +-- Runs the post-typechecking frontend (desugar and simplify), +-- and then generates and writes out the final interface. We want +-- to write the interface AFTER simplification so we can get +-- as up-to-date and good unfoldings and other info as possible +-- in the interface file. This is only ever run for HsSrcFile, +-- and NOT for HscNothing. +finish :: HscEnv + -> ModSummary + -> TcGblEnv + -> Maybe Fingerprint + -> Hsc (HscStatus, HomeModInfo, Bool) +finish hsc_env summary tc_result mb_old_hash = do + let dflags = hsc_dflags hsc_env + MASSERT( ms_hsc_src summary == HsSrcFile ) + MASSERT( hscTarget dflags /= HscNothing ) + guts0 <- hscDesugar' (ms_location summary) tc_result + guts <- hscSimplify' guts0 + (iface, changed, details, cgguts) <- liftIO $ hscNormalIface hsc_env guts mb_old_hash + + return (HscRecomp cgguts summary, + HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = Nothing }, + changed) + +hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO () +hscMaybeWriteIface dflags iface changed summary = + let force_write_interface = gopt Opt_WriteInterface dflags + write_interface = case hscTarget dflags of + HscNothing -> False + HscInterpreted -> False + _ -> True + in when (write_interface || force_write_interface) $ + hscWriteIface dflags iface changed summary -------------------------------------------------------------- -- NoRecomp handlers @@ -768,8 +783,9 @@ batchMsg hsc_env mod_index recomp mod_summary = -- | Given an 'HsBootMerge' 'ModSummary', merges all @hs-boot@ files -- under this module name into a composite, publically visible 'ModIface'. -hscMergeFrontEnd :: HscEnv -> ModSummary -> IO ModIface -hscMergeFrontEnd hsc_env mod_summary = do +hscMergeFrontEnd :: ModSummary -> Hsc ModIface +hscMergeFrontEnd mod_summary = do + hsc_env <- getHscEnv MASSERT( ms_hsc_src mod_summary == HsBootMerge ) let dflags = hsc_dflags hsc_env -- TODO: actually merge in signatures from external packages. @@ -783,7 +799,7 @@ hscMergeFrontEnd hsc_env mod_summary = do iface0 <- case lookupHptByModule hpt mod of Just hm -> return (hm_iface hm) Nothing -> do - mb_iface0 <- initIfaceCheck hsc_env + mb_iface0 <- liftIO . initIfaceCheck hsc_env $ findAndReadIface (text "merge-requirements") mod is_boot case mb_iface0 of diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index c4de91de24..7f51c332da 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -28,6 +28,9 @@ module TcRnTypes( IfGblEnv(..), IfLclEnv(..), tcVisibleOrphanMods, + -- Frontend types (shouldn't really be here) + FrontendResult(..), + -- Renamer types ErrCtxt, RecFieldEnv(..), ImportAvails(..), emptyImportAvails, plusImportAvails, @@ -326,6 +329,10 @@ data DsMetaVal ************************************************************************ -} +data FrontendResult + = FrontendTypecheck TcGblEnv + | FrontendMerge ModIface + -- | 'TcGblEnv' describes the top-level of the module at the -- point at which the typechecker is finished work. -- It is this structure that is handed on to the desugarer diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index cbfbd02a4c..17e0784cbc 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -400,7 +400,7 @@ test('T8959a', test('T703', normal, run_command, ['$MAKE -s --no-print-directory T703']) test('T2182', normal, run_command, ['$MAKE -s --no-print-directory T2182']) -test('T8101', normal, compile, ['-Wall -fno-code']) +test('T8101', expect_broken(10600), compile, ['-Wall -fno-code']) test('T8101b', expect_broken(10600), multimod_compile, ['T8101b', '-Wall -fno-code']) |