diff options
Diffstat (limited to 'compiler/main/DriverPipeline.hs')
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 97 |
1 files changed, 69 insertions, 28 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 03a55aef02..0dc75e1ecc 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -77,6 +77,7 @@ import Data.List ( isInfixOf, intercalate ) import Data.Maybe import Data.Version import Data.Either ( partitionEithers ) +import Data.IORef import Data.Time ( UTCTime ) @@ -156,11 +157,15 @@ compileOne' m_tc_result mHscMessage debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) - (status, hmi0) <- hscIncrementalCompile + -- Run the pipeline up to codeGen (so everything up to, but not including, STG) + (status, hmi_details, m_iface) <- hscIncrementalCompile always_do_basic_recompilation_check m_tc_result mHscMessage hsc_env summary source_modified mb_old_iface (mod_index, nmods) + -- Build HMI from the results of the Core pipeline. + let coreHmi m_linkable = HomeModInfo (expectIface m_iface) hmi_details m_linkable + let flags = hsc_dflags hsc_env0 in do unless (gopt Opt_KeepHiFiles flags) $ addFilesToClean flags TFL_CurrentModule $ @@ -173,23 +178,23 @@ compileOne' m_tc_result mHscMessage (HscUpToDate, _) -> -- TODO recomp014 triggers this assert. What's going on?! -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) ) - return hmi0 { hm_linkable = maybe_old_linkable } + return $! coreHmi maybe_old_linkable (HscNotGeneratingCode, HscNothing) -> let mb_linkable = if isHsBootOrSig src_flavour then Nothing -- TODO: Questionable. else Just (LM (ms_hs_date summary) this_mod []) - in return hmi0 { hm_linkable = mb_linkable } + in return $! coreHmi mb_linkable (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode" (_, HscNothing) -> panic "compileOne HscNothing" (HscUpdateBoot, HscInterpreted) -> do - return hmi0 + return $! coreHmi Nothing (HscUpdateBoot, _) -> do touchObjectFile dflags object_filename - return hmi0 + return $! coreHmi Nothing (HscUpdateSig, HscInterpreted) -> - let linkable = LM (ms_hs_date summary) this_mod [] - in return hmi0 { hm_linkable = Just linkable } + let !linkable = LM (ms_hs_date summary) this_mod [] + in return $! coreHmi (Just linkable) (HscUpdateSig, _) -> do output_fn <- getOutputFilename next_phase (Temporary TFL_CurrentModule) basename dflags @@ -208,9 +213,16 @@ compileOne' m_tc_result mHscMessage (Just location) [] 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 + let !linkable = LM o_time this_mod [DotO object_filename] + return $! coreHmi $ 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 @@ -228,29 +240,44 @@ compileOne' m_tc_result mHscMessage -- 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) + let !linkable = LM unlinked_time (ms_mod summary) (hs_unlinked ++ stub_o) - return hmi0 { hm_linkable = Just linkable } - (HscRecomp cgguts summary, _) -> do + return $! HomeModInfo iface hmi_details (Just linkable) + (HscRecomp cgguts summary iface_gen, _) -> 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 (output_fn, Nothing, - Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) + Just (HscOut src_flavour mod_name + (HscRecomp cgguts summary iface_gen'))) (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] - return hmi0 { hm_linkable = Just linkable } + let !linkable = LM o_time this_mod [DotO object_filename] + return $! HomeModInfo iface hmi_details (Just linkable) where dflags0 = ms_hspp_opts summary + expectIface :: Maybe ModIface -> ModIface + expectIface = expectJust "compileOne': Interface expected " + this_mod = ms_mod summary location = ms_location summary input_fn = expectJust "compile:hs" (ml_hs_file location) @@ -735,17 +762,22 @@ pipeLoop phase input_fn = do -> do liftIO $ debugTraceMsg dflags 4 (text "Running phase" <+> ppr phase) (next_phase, output_fn) <- runHookedPhase phase input_fn dflags - r <- pipeLoop next_phase output_fn case phase of - HscOut {} -> - whenGeneratingDynamicToo dflags $ do - setDynFlags $ dynamicTooMkDynamicDynFlags dflags - -- TODO shouldn't ignore result: - _ <- pipeLoop phase input_fn - return () - _ -> - return () - return r + HscOut {} -> do + -- We don't pass Opt_BuildDynamicToo to the backend + -- in DynFlags. + -- Instead it's run twice with flags accordingly set + -- per run. + let noDynToo = pipeLoop next_phase output_fn + let dynToo = do + setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo + r <- pipeLoop next_phase output_fn + setDynFlags $ dynamicTooMkDynamicDynFlags dflags + -- TODO shouldn't ignore result: + _ <- pipeLoop phase input_fn + return r + ifGeneratingDynamicToo dflags dynToo noDynToo + _ -> pipeLoop next_phase output_fn runHookedPhase :: PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath) @@ -1112,7 +1144,7 @@ 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, _, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' mod_summary source_unchanged Nothing (1,1) return (HscOut src_flavour mod_name result, @@ -1149,13 +1181,22 @@ 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 + HscRecomp cgguts mod_summary iface_gen -> do output_fn <- phaseOutputFilename next_phase PipeState{hsc_env=hsc_env'} <- getPipeState (outputFilename, mStub, foreign_files) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary output_fn + + + (iface, no_change) <- liftIO iface_gen + + -- See Note [Writing interface files] + let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo + liftIO $ hscMaybeWriteIface if_dflags iface no_change + (ms_location mod_summary) + stub_o <- liftIO (mapM (compileStub hsc_env') mStub) foreign_os <- liftIO $ mapM (uncurry (compileForeign hsc_env')) foreign_files |