Commit bbdd54aa authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan Committed by Marge Bot

Return ModIface in compilation pipeline, remove IORef hack for generating ModIfaces

The compilation phases now optionally return ModIface (for phases that
generate an interface, currently only HscOut when (re)compiling a file).
The value is then used by compileOne' to return the generated interface
with HomeModInfo (which is then used by the batch mode compiler when
building rest of the tree).

hscIncrementalMode also returns a DynFlags with plugin info, to be used
in the rest of the pipeline.

Unfortunately this introduces a (perhaps less bad) hack in place of the
previous IORef: we now record the DynFlags used to generate the partial
infterface in HscRecomp and use the same DynFlags when generating the
full interface. I spent almost three days trying to understand what's
changing in DynFlags that causes a backpack test to fail, but I couldn't
figure it out. There's a FIXME added next to the field so hopefully
someone who understands this better than I do will fix it leter.
parent 3bd3456f
......@@ -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
......
......@@ -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
......
......@@ -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.
......
......@@ -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 }, ())
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment