diff options
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 123 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 49 | ||||
| -rw-r--r-- | compiler/main/HscTypes.hs | 18 | ||||
| -rw-r--r-- | compiler/main/PipelineMonad.hs | 21 |
4 files changed, 114 insertions, 97 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 18f22d6d78..4d418b99fe 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -66,6 +66,7 @@ import FileCleanup import Ar import Bag ( unitBag ) import FastString ( mkFastString ) +import MkIface ( mkFullIface ) import Exception import System.Directory @@ -76,7 +77,6 @@ import Data.List ( isInfixOf, intercalate ) import Data.Maybe import Data.Version import Data.Either ( partitionEithers ) -import Data.IORef import Data.Time ( UTCTime ) @@ -98,15 +98,18 @@ preprocess :: HscEnv preprocess hsc_env input_fn mb_input_buf mb_phase = handleSourceError (\err -> return (Left (srcErrorMessages err))) $ ghandle handler $ - fmap Right $ - ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) - runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) + fmap Right $ do + MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) + (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) Nothing -- We keep the processed file for the whole session to save on -- duplicated work in ghci. (Temporary TFL_GhcSession) Nothing{-no ModLocation-} []{-no foreign objects-} + -- We stop before Hsc phase so we shouldn't generate an interface + MASSERT(isNothing mb_iface) + return (dflags, fp) where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 handler (ProgramError msg) = return $ Left $ unitBag $ @@ -157,7 +160,7 @@ compileOne' m_tc_result mHscMessage debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) -- Run the pipeline up to codeGen (so everything up to, but not including, STG) - (status, hmi_details) <- hscIncrementalCompile + (status, hmi_details, plugin_dflags) <- hscIncrementalCompile always_do_basic_recompilation_check m_tc_result mHscMessage hsc_env summary source_modified mb_old_iface (mod_index, nmods) @@ -170,6 +173,10 @@ compileOne' m_tc_result mHscMessage addFilesToClean flags TFL_GhcSession $ [ml_obj_file $ ms_location summary] + -- Use an HscEnv with DynFlags updated with the plugin info (returned from + -- hscIncrementalCompile) + let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags } + case (status, hsc_lang) of (HscUpToDate iface, _) -> -- TODO recomp014 triggers this assert. What's going on?! @@ -199,7 +206,7 @@ compileOne' m_tc_result mHscMessage -- #10660: Use the pipeline instead of calling -- compileEmptyStub directly, so -dynamic-too gets -- handled properly - _ <- runPipeline StopLn hsc_env + _ <- runPipeline StopLn hsc_env' (output_fn, Nothing, Just (HscOut src_flavour @@ -211,21 +218,22 @@ compileOne' m_tc_result mHscMessage o_time <- getModificationUTCTime object_filename let !linkable = LM o_time this_mod [DotO object_filename] return $! HomeModInfo iface hmi_details (Just linkable) - (HscRecomp cgguts summary iface_gen, HscInterpreted) -> do - -- In interpreted mode the regular codeGen backend is not run - -- so we generate a interface without codeGen info. - (iface, no_change) <- iface_gen - -- If we interpret the code, then we can write the interface file here. - liftIO $ hscMaybeWriteIface dflags iface no_change - (ms_location summary) - - (hasStub, comp_bc, spt_entries) <- - hscInteractive hsc_env cgguts summary + (HscRecomp { hscs_guts = cgguts, + hscs_summary = summary, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash, + hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do + -- In interpreted mode the regular codeGen backend is not run so we + -- generate a interface without codeGen info. + final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface + liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary) + + (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts summary stub_o <- case hasStub of Nothing -> return [] Just stub_c -> do - stub_o <- compileStub hsc_env stub_c + stub_o <- compileStub hsc_env' stub_c return [DotO stub_o] let hs_unlinked = [BCOs comp_bc spt_entries] @@ -238,32 +246,20 @@ compileOne' m_tc_result mHscMessage -- be out of date. let !linkable = LM unlinked_time (ms_mod summary) (hs_unlinked ++ stub_o) - return $! HomeModInfo iface hmi_details (Just linkable) - (HscRecomp cgguts summary iface_gen, _) -> do + return $! HomeModInfo final_iface hmi_details (Just linkable) + (HscRecomp{}, _) -> do output_fn <- getOutputFilename next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) -- We're in --make mode: finish the compilation pipeline. - - -- We use this IORef the get out the iface from the otherwise - -- opaque pipeline once it's created. Otherwise we would have - -- to thread it through runPipeline. - if_ref <- newIORef Nothing :: IO (IORef (Maybe ModIface)) - let iface_gen' = do - res@(iface, _no_change) <- iface_gen - writeIORef if_ref $ Just iface - return res - - _ <- runPipeline StopLn hsc_env + (_, _, Just iface) <- runPipeline StopLn hsc_env' (output_fn, Nothing, - Just (HscOut src_flavour mod_name - (HscRecomp cgguts summary iface_gen'))) + Just (HscOut src_flavour mod_name status)) (Just basename) Persistent (Just location) [] - iface <- (expectJust "Iface callback") <$> readIORef if_ref -- The object filename comes from the ModLocation o_time <- getModificationUTCTime object_filename let !linkable = LM o_time this_mod [DotO object_filename] @@ -354,7 +350,7 @@ compileForeign hsc_env lang stub_c = do LangObjcxx -> Cobjcxx LangAsm -> As True -- allow CPP RawObject -> panic "compileForeign: should be unreachable" - (_, stub_o) <- runPipeline StopLn hsc_env + (_, stub_o, _) <- runPipeline StopLn hsc_env (stub_c, Nothing, Just (RealPhase phase)) Nothing (Temporary TFL_GhcSession) Nothing{-no ModLocation-} @@ -563,7 +559,7 @@ compileFile hsc_env stop_phase (src, mb_phase) = do -- -o foo applies to the file we are compiling now | otherwise = Persistent - ( _, out_file) <- runPipeline stop_phase hsc_env + ( _, out_file, _) <- runPipeline stop_phase hsc_env (src, Nothing, fmap RealPhase mb_phase) Nothing output @@ -606,7 +602,8 @@ runPipeline -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects - -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) + -> IO (DynFlags, FilePath, Maybe ModIface) + -- ^ (final flags, output filename, interface) runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) mb_basename output maybe_loc foreign_os @@ -700,20 +697,21 @@ runPipeline' -> FilePath -- ^ Input filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects, if we have one - -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) + -> IO (DynFlags, FilePath, Maybe ModIface) + -- ^ (final flags, output filename, interface) runPipeline' start_phase hsc_env env input_fn maybe_loc foreign_os = do -- Execute the pipeline... - let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os } - - evalP (pipeLoop start_phase input_fn) env state + let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing } + (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state + return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state) -- --------------------------------------------------------------------------- -- outer pipeline loop -- | pipeLoop runs phases until we reach the stop phase -pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath) +pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath pipeLoop phase input_fn = do env <- getPipeEnv dflags <- getDynFlags @@ -729,7 +727,7 @@ pipeLoop phase input_fn = do -- further compilation stages can tell what the original filename was. case output_spec env of Temporary _ -> - return (dflags, input_fn) + return input_fn output -> do pst <- getPipeState final_fn <- liftIO $ getOutputFilename @@ -739,7 +737,7 @@ pipeLoop phase input_fn = do let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn - return (dflags, final_fn) + return final_fn | not (realPhase `happensBefore'` stopPhase) @@ -1136,9 +1134,13 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 -- run the compiler! let msg hsc_env _ what _ = oneShotMsg hsc_env what - (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' + (result, _mod_details, plugin_dflags) <- + liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' mod_summary source_unchanged Nothing (1,1) + -- In the rest of the pipeline use the dflags with plugin info + setDynFlags plugin_dflags + return (HscOut src_flavour mod_name result, panic "HscOut doesn't have an input filename") @@ -1173,7 +1175,11 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do basename = dropExtension input_fn liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name return (RealPhase StopLn, o_file) - HscRecomp cgguts mod_summary iface_gen + HscRecomp { hscs_guts = cgguts, + hscs_summary = mod_summary, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash, + hscs_iface_dflags = iface_dflags } -> do output_fn <- phaseOutputFilename next_phase PipeState{hsc_env=hsc_env'} <- getPipeState @@ -1181,12 +1187,12 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do (outputFilename, mStub, foreign_files) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary output_fn - - (iface, no_change) <- liftIO iface_gen + final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface) + setIface final_iface -- See Note [Writing interface files] let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo - liftIO $ hscMaybeWriteIface if_dflags iface no_change + liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash (ms_location mod_summary) stub_o <- liftIO (mapM (compileStub hsc_env') mStub) @@ -1200,25 +1206,18 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do -- Cmm phase runPhase (RealPhase CmmCpp) input_fn dflags - = do - output_fn <- phaseOutputFilename Cmm + = do output_fn <- phaseOutputFilename Cmm liftIO $ doCpp dflags False{-not raw-} input_fn output_fn return (RealPhase Cmm, output_fn) runPhase (RealPhase Cmm) input_fn dflags - = do - let hsc_lang = hscTarget dflags - - let next_phase = hscPostBackendPhase HsSrcFile hsc_lang - - output_fn <- phaseOutputFilename next_phase - - PipeState{hsc_env} <- getPipeState - - liftIO $ hscCompileCmmFile hsc_env input_fn output_fn - - return (RealPhase next_phase, output_fn) + = do let hsc_lang = hscTarget dflags + let next_phase = hscPostBackendPhase HsSrcFile hsc_lang + output_fn <- phaseOutputFilename next_phase + PipeState{hsc_env} <- getPipeState + liftIO $ hscCompileCmmFile hsc_env input_fn output_fn + return (RealPhase next_phase, output_fn) ----------------------------------------------------------------------------- -- Cc phase diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 9ed2710ee8..16f50f11e9 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -727,7 +727,7 @@ hscIncrementalCompile :: Bool -> SourceModified -> Maybe ModIface -> (Int,Int) - -> IO (HscStatus, ModDetails) + -> IO (HscStatus, ModDetails, DynFlags) hscIncrementalCompile always_do_basic_recompilation_check m_tc_result mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index = do @@ -768,13 +768,14 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result -- in make mode, since this HMI will go into the HPT. details <- genModDetails hsc_env' iface return details - return (HscUpToDate iface, details) + return (HscUpToDate iface, details, dflags) -- We finished type checking. (mb_old_hash is the hash of -- the interface that existed on disk; it's possible we had -- to retypecheck but the resulting interface is exactly -- the same.) - Right (FrontendTypecheck tc_result, mb_old_hash) -> - finish mod_summary tc_result mb_old_hash + Right (FrontendTypecheck tc_result, mb_old_hash) -> do + (status, mb_old_hash) <- finish mod_summary tc_result mb_old_hash + return (status, mb_old_hash, dflags) -- Runs the post-typechecking frontend (desugar and simplify). We want to -- generate most of the interface as late as possible. This gets us up-to-date @@ -801,10 +802,10 @@ finish summary tc_result mb_old_hash = do ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile mk_simple_iface :: Hsc (HscStatus, ModDetails) mk_simple_iface = do - (iface, no_change, details) <- liftIO $ + (iface, mb_old_iface_hash, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash - liftIO $ hscMaybeWriteIface dflags iface no_change (ms_location summary) + liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary) let hsc_status = case (target, hsc_src) of @@ -838,19 +839,12 @@ finish summary tc_result mb_old_hash = do -- See Note [Avoiding space leaks in toIface*] for details. force (mkPartialIface hsc_env details desugared_guts) - let iface_gen :: IO (ModIface, Bool) - iface_gen = do - -- Build a fully instantiated ModIface. - -- This has to happen *after* code gen so that the back-end - -- info has been set. - -- This captures hsc_env, but it seems we keep it alive in other - -- ways as well so we don't bother extracting only the relevant parts. - dumpIfaceStats hsc_env - final_iface <- mkFullIface hsc_env partial_iface - let no_change = mb_old_hash == Just (mi_iface_hash (mi_final_exts final_iface)) - return (final_iface, no_change) - - return ( HscRecomp cg_guts summary iface_gen, details ) + return ( HscRecomp { hscs_guts = cg_guts, + hscs_summary = summary, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_hash, + hscs_iface_dflags = dflags }, + details ) else mk_simple_iface @@ -868,15 +862,17 @@ hscMaybeWriteIface, but only once per compilation (twice with dynamic-too). In this case we create the interface file inside RunPhase using the interface generator contained inside the HscRecomp status. -} -hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO () -hscMaybeWriteIface dflags iface no_change location = +hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () +hscMaybeWriteIface dflags iface old_iface location = do 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 no_change location + no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) + + when (write_interface || force_write_interface) $ + hscWriteIface dflags iface no_change location -------------------------------------------------------------- -- NoRecomp handlers @@ -1341,13 +1337,13 @@ hscSimplify' plugins ds_result = do hscSimpleIface :: HscEnv -> TcGblEnv -> Maybe Fingerprint - -> IO (ModIface, Bool, ModDetails) + -> IO (ModIface, Maybe Fingerprint, ModDetails) hscSimpleIface hsc_env tc_result mb_old_iface = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface hscSimpleIface' :: TcGblEnv -> Maybe Fingerprint - -> Hsc (ModIface, Bool, ModDetails) + -> Hsc (ModIface, Maybe Fingerprint, ModDetails) hscSimpleIface' tc_result mb_old_iface = do hsc_env <- getHscEnv details <- liftIO $ mkBootModDetailsTc hsc_env tc_result @@ -1356,10 +1352,9 @@ hscSimpleIface' tc_result mb_old_iface = do <- {-# SCC "MkFinalIface" #-} liftIO $ mkIfaceTc hsc_env safe_mode details tc_result - let no_change = mb_old_iface == Just (mi_iface_hash (mi_final_exts new_iface)) -- And the answer is ... liftIO $ dumpIfaceStats hsc_env - return (new_iface, no_change, details) + return (new_iface, mb_old_iface, details) -------------------------------------------------------------- -- BackEnd combinators diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 4b251af436..ca321d6405 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -242,11 +242,21 @@ data HscStatus -- | Recompile this module. | HscRecomp { hscs_guts :: CgGuts - -- ^ Information for the code generator. + -- ^ Information for the code generator. , hscs_summary :: ModSummary - -- ^ Module info - , hscs_iface_gen :: IO (ModIface, Bool) - -- ^ Action to generate iface after codegen. + -- ^ Module info + , hscs_partial_iface :: !PartialModIface + -- ^ Partial interface + , hscs_old_iface_hash :: !(Maybe Fingerprint) + -- ^ Old interface hash for this compilation, if an old interface file + -- exists. Pass to `hscMaybeWriteIface` when writing the interface to + -- avoid updating the existing interface when the interface isn't + -- changed. + , hscs_iface_dflags :: !DynFlags + -- ^ Generate final iface using this DynFlags. + -- FIXME (osa): I don't understand why this is necessary, but I spent + -- almost two days trying to figure this out and I couldn't .. perhaps + -- someone who understands this code better will remove this later. } -- Should HscStatus contain the HomeModInfo? -- All places where we return a status we also return a HomeModInfo. diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs index d152d04530..bdda19ceac 100644 --- a/compiler/main/PipelineMonad.hs +++ b/compiler/main/PipelineMonad.hs @@ -7,7 +7,8 @@ module PipelineMonad ( CompPipeline(..), evalP , PhasePlus(..) , PipeEnv(..), PipeState(..), PipelineOutput(..) - , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs + , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface + , pipeStateDynFlags, pipeStateModIface ) where import GhcPrelude @@ -25,8 +26,8 @@ import Control.Monad newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } deriving (Functor) -evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a -evalP f env st = liftM snd $ unP f env st +evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a) +evalP (P f) env st = f env st instance Applicative CompPipeline where pure a = P $ \_env state -> return (state, a) @@ -67,12 +68,21 @@ data PipeState = PipeState { maybe_loc :: Maybe ModLocation, -- ^ the ModLocation. This is discovered during compilation, -- in the Hsc phase where we read the module header. - foreign_os :: [FilePath] + foreign_os :: [FilePath], -- ^ additional object files resulting from compiling foreign -- code. They come from two sources: foreign stubs, and -- add{C,Cxx,Objc,Objcxx}File from template haskell + iface :: Maybe ModIface + -- ^ Interface generated by HscOut phase. Only available after the + -- phase runs. } +pipeStateDynFlags :: PipeState -> DynFlags +pipeStateDynFlags = hsc_dflags . hsc_env + +pipeStateModIface :: PipeState -> Maybe ModIface +pipeStateModIface = iface + data PipelineOutput = Temporary TempFileLifetime -- ^ Output should be to a temporary file: we're going to @@ -107,3 +117,6 @@ setModLocation loc = P $ \_env state -> setForeignOs :: [FilePath] -> CompPipeline () setForeignOs os = P $ \_env state -> return (state{ foreign_os = os }, ()) + +setIface :: ModIface -> CompPipeline () +setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ()) |