summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
authorÖmer Sinan Ağacan <omeragacan@gmail.com>2019-08-21 17:31:49 +0300
committerAndreas Klebinger <klebinger.andreas@gmx.at>2019-09-28 11:47:05 +0200
commit4651095e3924e6643c9434f6ef0ba8310072b565 (patch)
tree3b848eae11ce34a6a6494071a6923913a92df424 /compiler/main
parent4f81fab062e521b6b59f3f7b93bc410fd1111166 (diff)
downloadhaskell-wip/osa1/backend_refactoring.tar.gz
Refactor iface file generation:wip/osa1/backend_refactoring
This commit refactors interface file generation to allow information from the later passed (NCG, STG) to be stored in interface files. We achieve this by splitting interface file generation into two parts: * Partial interfaces, built based on the result of the core pipeline * A fully instantiated interface, which also contains the final fingerprints and can optionally contain information produced by the backend. This change is required by !1304 and !1530. -dynamic-too handling is refactored too: previously when generating code we'd branch on -dynamic-too *before* code generation, but now we do it after. (Original code written by @AndreasK in !1530) Performance ~~~~~~~~~~~ Before this patch interface files where created and immediately flushed to disk which made space leaks impossible. With this change we instead use NFData to force all iface related data structures to avoid space leaks. In the process of refactoring it was discovered that the code in the ToIface Module allocated a lot of thunks which were immediately forced when writing/forcing the interface file. So we made this module more strict to avoid creating many of those thunks. Bottom line is that allocations go down by about ~0.1% compared to master. Residency is not meaningfully different after this patch. Runtime was not benchmarked. Co-Authored-By: Andreas Klebinger <klebinger.andreas@gmx.at> Co-Authored-By: Ömer Sinan Ağacan <omer@well-typed.com>
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/DriverPipeline.hs97
-rw-r--r--compiler/main/GHC.hs2
-rw-r--r--compiler/main/HscMain.hs223
-rw-r--r--compiler/main/HscTypes.hs263
4 files changed, 381 insertions, 204 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
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index a66daa220e..f948f454a7 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -85,7 +85,7 @@ module GHC (
lookupGlobalName,
findGlobalAnns,
mkPrintUnqualifiedForModule,
- ModIface(..),
+ ModIface, ModIface_(..),
SafeHaskellMode(..),
-- * Querying the environment
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index a9fe3ffe18..b21609bbc5 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -39,6 +39,7 @@ module HscMain
, Messager, batchMsg
, HscStatus (..)
, hscIncrementalCompile
+ , hscMaybeWriteIface
, hscCompileCmmFile
, hscGenHardCode
@@ -75,7 +76,7 @@ module HscMain
-- hscFileFrontEnd in client code
, hscParse', hscSimplify', hscDesugar', tcRnModule'
, getHscEnv
- , hscSimpleIface', hscNormalIface'
+ , hscSimpleIface'
, oneShotMsg
, hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
, ioMsgMaybe
@@ -172,6 +173,7 @@ import System.IO (fixIO)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Set (Set)
+import Control.DeepSeq (force)
import HieAst ( mkHieFile )
import HieTypes ( getAsts, hie_asts, hie_module )
@@ -672,7 +674,7 @@ hscIncrementalFrontend
-- 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
+ let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface
case mb_checked_iface of
Just iface | not (recompileRequired recomp_reqd) ->
@@ -713,7 +715,11 @@ genericHscFrontend' mod_summary
-- Compilers
--------------------------------------------------------------
--- Compile Haskell/boot in OneShot mode.
+-- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts
+-- of the pipeline.
+-- We return a interface if we already had an old one around and recompilation
+-- was not needed. Otherwise it will be created during later passes when we
+-- run the compilation pipeline.
hscIncrementalCompile :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
@@ -722,9 +728,7 @@ hscIncrementalCompile :: Bool
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
- -- HomeModInfo does not contain linkable, since we haven't
- -- code-genned yet
- -> IO (HscStatus, HomeModInfo)
+ -> IO (HscStatus, ModDetails, Maybe ModIface)
hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
= do
@@ -753,22 +757,19 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
-- file on disk was good enough.
Left iface -> do
-- Knot tying! See Note [Knot-tying typecheckIface]
- hmi <- liftIO . fixIO $ \hmi' -> do
+ details <- liftIO . fixIO $ \details' -> do
let hsc_env' =
hsc_env {
hsc_HPT = addToHpt (hsc_HPT hsc_env)
- (ms_mod_name mod_summary) hmi'
+ (ms_mod_name mod_summary) (HomeModInfo iface details' Nothing)
}
-- NB: This result is actually not that useful
-- in one-shot mode, since we're not going to do
-- any further typechecking. It's much more useful
-- in make mode, since this HMI will go into the HPT.
details <- genModDetails hsc_env' iface
- return HomeModInfo{
- hm_details = details,
- hm_iface = iface,
- hm_linkable = Nothing }
- return (HscUpToDate, hmi)
+ return details
+ return (HscUpToDate, details, Just iface)
-- 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
@@ -776,15 +777,22 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
Right (FrontendTypecheck tc_result, mb_old_hash) ->
finish mod_summary tc_result mb_old_hash
--- 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.
+-- 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
+-- and good unfoldings and other info in the interface file.
+--
+-- We might create a interface right away, in which case we also return the
+-- updated HomeModInfo. But we might also need to run the backend first. In the
+-- later case Status will be HscRecomp and we return a function from ModIface ->
+-- HomeModInfo.
+--
+-- HscRecomp in turn will carry the information required to compute a interface
+-- when passed the result of the code generator. So all this can and is done at
+-- the call site of the backend code gen if it is run.
finish :: ModSummary
-> TcGblEnv
-> Maybe Fingerprint
- -> Hsc (HscStatus, HomeModInfo)
+ -> Hsc (HscStatus, ModDetails, Maybe ModIface)
finish summary tc_result mb_old_hash = do
hsc_env <- getHscEnv
let dflags = hsc_dflags hsc_env
@@ -792,6 +800,7 @@ finish summary tc_result mb_old_hash = do
hsc_src = ms_hsc_src summary
should_desugar =
ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
+ mk_simple_iface :: Hsc (HscStatus, ModDetails, Maybe ModIface)
mk_simple_iface = do
let hsc_status =
case (target, hsc_src) of
@@ -801,41 +810,74 @@ finish summary tc_result mb_old_hash = do
_ -> panic "finish"
(iface, no_change, details) <- liftIO $
hscSimpleIface hsc_env tc_result mb_old_hash
- return (iface, no_change, details, hsc_status)
- (iface, no_change, details, hsc_status) <-
- -- we usually desugar even when we are not generating code, otherwise
- -- we would miss errors thrown by the desugaring (see #10600). The only
- -- exceptions are when the Module is Ghc.Prim or when
- -- it is not a HsSrcFile Module.
- if should_desugar
- then do
- desugared_guts0 <- hscDesugar' (ms_location summary) tc_result
- if target == HscNothing
- -- We are not generating code, so we can skip simplification
- -- and generate a simple interface.
- then mk_simple_iface
- else do
- plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
- desugared_guts <- hscSimplify' plugins desugared_guts0
- (iface, no_change, details, cgguts) <-
- liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash
- return (iface, no_change, details, HscRecomp cgguts summary)
- else mk_simple_iface
- liftIO $ hscMaybeWriteIface dflags iface no_change summary
- return
- ( hsc_status
- , HomeModInfo
- {hm_details = details, hm_iface = iface, hm_linkable = Nothing})
-
-hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
-hscMaybeWriteIface dflags iface no_change summary =
+
+ liftIO $ hscMaybeWriteIface dflags iface no_change (ms_location summary)
+ return (hsc_status, details, Just iface)
+
+ -- we usually desugar even when we are not generating code, otherwise
+ -- we would miss errors thrown by the desugaring (see #10600). The only
+ -- exceptions are when the Module is Ghc.Prim or when
+ -- it is not a HsSrcFile Module.
+ if should_desugar
+ then do
+ desugared_guts0 <- hscDesugar' (ms_location summary) tc_result
+ if target == HscNothing
+ -- We are not generating code, so we can skip simplification
+ -- and generate a simple interface.
+ then mk_simple_iface
+ else do
+ plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
+ desugared_guts <- hscSimplify' plugins desugared_guts0
+
+ (cg_guts, details) <- {-# SCC "CoreTidy" #-}
+ liftIO $ tidyProgram hsc_env desugared_guts
+
+ let !partial_iface =
+ {-# SCC "HscMain.mkPartialIface" #-}
+ -- This `force` saves 2M residency in test T10370
+ -- 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, Nothing )
+ else mk_simple_iface
+
+
+{-
+Note [Writing interface files]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We write interface files in HscMain.hs and DriverPipeline.hs using
+hscMaybeWriteIface, but only once per compilation (twice with dynamic-too).
+
+* If a compilation does NOT require (re)compilation of the hard code we call
+ hscMaybeWriteIface inside HscMain:finish.
+* If we run in One Shot mode and target bytecode we write it in compileOne'
+* Otherwise we must be compiling to regular hard code and require recompilation.
+ 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 =
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 summary
+ hscWriteIface dflags iface no_change location
--------------------------------------------------------------
-- NoRecomp handlers
@@ -1295,6 +1337,8 @@ hscSimplify' plugins ds_result = do
-- Interface generators
--------------------------------------------------------------
+-- | Generate a striped down interface file, e.g. for boot files or when ghci
+-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]
hscSimpleIface :: HscEnv
-> TcGblEnv
-> Maybe Fingerprint
@@ -1309,62 +1353,63 @@ hscSimpleIface' tc_result mb_old_iface = do
hsc_env <- getHscEnv
details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
safe_mode <- hscGetSafeMode tc_result
- (new_iface, no_change)
+ new_iface
<- {-# SCC "MkFinalIface" #-}
liftIO $
- mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
+ 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)
-hscNormalIface :: HscEnv
- -> ModGuts
- -> Maybe Fingerprint
- -> IO (ModIface, Bool, ModDetails, CgGuts)
-hscNormalIface hsc_env simpl_result mb_old_iface =
- runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
+--------------------------------------------------------------
+-- BackEnd combinators
+--------------------------------------------------------------
+{-
+Note [Interface filename extensions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-hscNormalIface' :: ModGuts
- -> Maybe Fingerprint
- -> Hsc (ModIface, Bool, ModDetails, CgGuts)
-hscNormalIface' simpl_result mb_old_iface = do
- hsc_env <- getHscEnv
- (cg_guts, details) <- {-# SCC "CoreTidy" #-}
- liftIO $ tidyProgram hsc_env simpl_result
-
- -- BUILD THE NEW ModIface and ModDetails
- -- and emit external core if necessary
- -- This has to happen *after* code gen so that the back-end
- -- info has been set. Not yet clear if it matters waiting
- -- until after code output
- (new_iface, no_change)
- <- {-# SCC "MkFinalIface" #-}
- liftIO $
- mkIface hsc_env mb_old_iface details simpl_result
+ModLocation only contains the base names, however when generating dynamic files
+the actual extension might differ from the default.
- liftIO $ dumpIfaceStats hsc_env
+So we only load the base name from ModLocation and replace the actual extension
+according to the information in DynFlags.
- -- Return the prepared code.
- return (new_iface, no_change, details, cg_guts)
+If we generate a interface file right after running the core pipeline we will
+have set -dynamic-too and potentially generate both interface files at the same
+time.
---------------------------------------------------------------
--- BackEnd combinators
---------------------------------------------------------------
+If we generate a interface file after running the backend then dynamic-too won't
+be set, however then the extension will be contained in the dynflags instead so
+things still work out fine.
+-}
-hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
-hscWriteIface dflags iface no_change mod_summary = do
- let ifaceFile = ml_hi_file (ms_location mod_summary)
+hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO ()
+hscWriteIface dflags iface no_change mod_location = do
+ -- mod_location only contains the base name, so we rebuild the
+ -- correct file extension from the dynflags.
+ let ifaceBaseFile = ml_hi_file mod_location
unless no_change $
- {-# SCC "writeIface" #-}
- writeIfaceFile dflags ifaceFile iface
+ let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags)
+ in {-# SCC "writeIface" #-}
+ writeIfaceFile dflags ifaceFile iface
whenGeneratingDynamicToo dflags $ do
-- TODO: We should do a no_change check for the dynamic
-- interface file too
- -- TODO: Should handle the dynamic hi filename properly
- let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
- dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
- dynDflags = dynamicTooMkDynamicDynFlags dflags
- writeIfaceFile dynDflags dynIfaceFile' iface
+ -- When we generate iface files after core
+ let dynDflags = dynamicTooMkDynamicDynFlags dflags
+ -- dynDflags will have set hiSuf correctly.
+ dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags)
+
+ writeIfaceFile dynDflags dynIfaceFile iface
+ where
+ buildIfName :: String -> String -> String
+ buildIfName baseName suffix
+ | Just name <- outputHi dflags
+ = name
+ | otherwise
+ = let with_hi = replaceExtension baseName suffix
+ in addBootSuffix_maybe (mi_boot iface) with_hi
-- | Compile to hard-code.
hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 274b777eec..eeaa2c2f1d 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -8,6 +8,12 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DataKinds #-}
-- | Types for the per-module compiler
module HscTypes (
@@ -53,7 +59,7 @@ module HscTypes (
-- * State relating to known packages
ExternalPackageState(..), EpsStats(..), addEpsInStats,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
- lookupIfaceByModule, emptyModIface, lookupHptByModule,
+ lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule,
PackageInstEnv, PackageFamInstEnv, PackageRuleBase,
PackageCompleteMatchMap,
@@ -80,7 +86,8 @@ module HscTypes (
mkQualPackage, mkQualModule, pkgQual,
-- * Interfaces
- ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
+ ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..),
+ mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
emptyIfaceWarnCache, mi_boot, mi_fix,
mi_semantic_module,
mi_free_holes,
@@ -216,6 +223,7 @@ import Exception
import System.FilePath
import Control.Concurrent
import System.Process ( ProcessHandle )
+import Control.DeepSeq
-- -----------------------------------------------------------------------------
-- Compilation state
@@ -223,11 +231,20 @@ import System.Process ( ProcessHandle )
-- | Status of a compilation to hard-code
data HscStatus
- = HscNotGeneratingCode
- | HscUpToDate
- | HscUpdateBoot
- | HscUpdateSig
- | HscRecomp CgGuts ModSummary
+ = HscNotGeneratingCode -- ^ Nothing to do.
+ | HscUpToDate -- ^ Nothing to do because code already exists.
+ | HscUpdateBoot -- ^ Update boot file result.
+ | HscUpdateSig -- ^ Generate signature file (backpack)
+ | HscRecomp -- ^ Recompile this module.
+ { hscs_guts :: CgGuts
+ -- ^ Information for the code generator.
+ , hscs_summary :: ModSummary
+ -- ^ Module info
+ , hscs_iface_gen :: IO (ModIface, Bool)
+ -- ^ Action to generate iface after codegen.
+ }
+-- Should HscStatus contain the HomeModInfo?
+-- All places where we return a status we also return a HomeModInfo.
-- -----------------------------------------------------------------------------
-- The Hsc monad: Passing an environment and warning state
@@ -856,6 +873,86 @@ data FindResult
************************************************************************
-}
+{- Note [Interface file stages]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Interface files have two possible stages.
+
+* A partial stage built from the result of the core pipeline.
+* A fully instantiated form. Which also includes fingerprints and
+ potentially information provided by backends.
+
+We can build a full interface file two ways:
+* Directly from a partial one:
+ Then we omit backend information and mostly compute fingerprints.
+* From a partial one + information produced by a backend.
+ Then we store the provided information and fingerprint both.
+-}
+
+type PartialModIface = ModIface_ 'ModIfaceCore
+type ModIface = ModIface_ 'ModIfaceFinal
+
+-- | Extends a PartialModIface with information which is either:
+-- * Computed after codegen
+-- * Or computed just before writing the iface to disk. (Hashes)
+-- In order to fully instantiate it.
+data ModIfaceBackend = ModIfaceBackend
+ { mi_iface_hash :: !Fingerprint
+ -- ^ Hash of the whole interface
+ , mi_mod_hash :: !Fingerprint
+ -- ^ Hash of the ABI only
+ , mi_flag_hash :: !Fingerprint
+ -- ^ Hash of the important flags used when compiling the module, excluding
+ -- optimisation flags
+ , mi_opt_hash :: !Fingerprint
+ -- ^ Hash of optimisation flags
+ , mi_hpc_hash :: !Fingerprint
+ -- ^ Hash of hpc flags
+ , mi_plugin_hash :: !Fingerprint
+ -- ^ Hash of plugins
+ , mi_orphan :: !WhetherHasOrphans
+ -- ^ Whether this module has orphans
+ , mi_finsts :: !WhetherHasFamInst
+ -- ^ Whether this module has family instances. See Note [The type family
+ -- instance consistency story].
+ , mi_exp_hash :: !Fingerprint
+ -- ^ Hash of export list
+ , mi_orphan_hash :: !Fingerprint
+ -- ^ Hash for orphan rules, class and family instances combined
+
+ -- Cached environments for easy lookup. These are computed (lazily) from
+ -- other fields and are not put into the interface file.
+ -- Not really produced by the backend but there is no need to create them
+ -- any earlier.
+ , mi_warn_fn :: !(OccName -> Maybe WarningTxt)
+ -- ^ Cached lookup for 'mi_warns'
+ , mi_fix_fn :: !(OccName -> Maybe Fixity)
+ -- ^ Cached lookup for 'mi_fixities'
+ , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))
+ -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that
+ -- the thing isn't in decls. It's useful to know that when seeing if we are
+ -- up to date wrt. the old interface. The 'OccName' is the parent of the
+ -- name, if it has one.
+ }
+
+data ModIfacePhase
+ = ModIfaceCore
+ -- ^ Partial interface built based on output of core pipeline.
+ | ModIfaceFinal
+
+-- | Selects a IfaceDecl representation.
+-- For fully instantiated interfaces we also maintain
+-- a fingerprint, which is used for recompilation checks.
+type family IfaceDeclExts (phase :: ModIfacePhase) where
+ IfaceDeclExts 'ModIfaceCore = IfaceDecl
+ IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl)
+
+type family IfaceBackendExts (phase :: ModIfacePhase) where
+ IfaceBackendExts 'ModIfaceCore = ()
+ IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend
+
+
+
-- | A 'ModIface' plus a 'ModDetails' summarises everything we know
-- about a compiled module. The 'ModIface' is the stuff *before* linking,
-- and can be written out to an interface file. The 'ModDetails is after
@@ -865,23 +962,11 @@ data FindResult
-- except that we explicitly make the 'mi_decls' and a few other fields empty;
-- as when reading we consolidate the declarations etc. into a number of indexed
-- maps and environments in the 'ExternalPackageState'.
-data ModIface
+data ModIface_ (phase :: ModIfacePhase)
= ModIface {
mi_module :: !Module, -- ^ Name of the module we are for
mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod?
- mi_iface_hash :: !Fingerprint, -- ^ Hash of the whole interface
- mi_mod_hash :: !Fingerprint, -- ^ Hash of the ABI only
- mi_flag_hash :: !Fingerprint, -- ^ Hash of the important flags
- -- used when compiling the module,
- -- excluding optimisation flags
- mi_opt_hash :: !Fingerprint, -- ^ Hash of optimisation flags
- mi_hpc_hash :: !Fingerprint, -- ^ Hash of hpc flags
- mi_plugin_hash :: !Fingerprint, -- ^ Hash of plugins
-
- mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans
- mi_finsts :: !WhetherHasFamInst,
- -- ^ Whether this module has family instances.
- -- See Note [The type family instance consistency story].
+
mi_hsc_src :: !HscSource, -- ^ Boot? Signature?
mi_deps :: Dependencies,
@@ -902,8 +987,6 @@ data ModIface
-- Records the modules that are the declaration points for things
-- exported by this module, and the 'OccName's of those things
- mi_exp_hash :: !Fingerprint,
- -- ^ Hash of export list
mi_used_th :: !Bool,
-- ^ Module required TH splices when it was compiled.
@@ -922,7 +1005,7 @@ data ModIface
-- NOT STRICT! we read this field lazily from the interface file
- mi_decls :: [(Fingerprint,IfaceDecl)],
+ mi_decls :: [IfaceDeclExts phase],
-- ^ Type, class and variable declarations
-- The hash of an Id changes if its fixity or deprecations change
-- (as well as its type of course)
@@ -948,22 +1031,6 @@ data ModIface
mi_insts :: [IfaceClsInst], -- ^ Sorted class instance
mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances
mi_rules :: [IfaceRule], -- ^ Sorted rules
- mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules, class and family
- -- instances combined
-
- -- Cached environments for easy lookup
- -- These are computed (lazily) from other fields
- -- and are not put into the interface file
- mi_warn_fn :: OccName -> Maybe WarningTxt,
- -- ^ Cached lookup for 'mi_warns'
- mi_fix_fn :: OccName -> Maybe Fixity,
- -- ^ Cached lookup for 'mi_fixities'
- mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint),
- -- ^ Cached lookup for 'mi_decls'.
- -- The @Nothing@ in 'mi_hash_fn' means that the thing
- -- isn't in decls. It's useful to know that when
- -- seeing if we are up to date wrt. the old interface.
- -- The 'OccName' is the parent of the name, if it has one.
mi_hpc :: !AnyHpcUsage,
-- ^ True if this program uses Hpc at any point in the program.
@@ -986,8 +1053,12 @@ data ModIface
mi_decl_docs :: DeclDocMap,
-- ^ Docs on declarations.
- mi_arg_docs :: ArgDocMap
+ mi_arg_docs :: ArgDocMap,
-- ^ Docs on arguments.
+
+ mi_final_exts :: !(IfaceBackendExts phase)
+ -- ^ Either `()` or `ModIfaceBackend` for
+ -- a fully instantiated interface.
}
-- | Old-style accessor for whether or not the ModIface came from an hs-boot
@@ -998,12 +1069,12 @@ mi_boot iface = mi_hsc_src iface == HsBootFile
-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be
-- found, 'defaultFixity' is returned instead.
mi_fix :: ModIface -> OccName -> Fixity
-mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity
+mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity
-- | The semantic module for this interface; e.g., if it's a interface
-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'
-- will be @<A>@.
-mi_semantic_module :: ModIface -> Module
+mi_semantic_module :: ModIface_ a -> Module
mi_semantic_module iface = case mi_sig_of iface of
Nothing -> mi_module iface
Just mod -> mod
@@ -1041,18 +1112,9 @@ instance Binary ModIface where
mi_module = mod,
mi_sig_of = sig_of,
mi_hsc_src = hsc_src,
- mi_iface_hash= iface_hash,
- mi_mod_hash = mod_hash,
- mi_flag_hash = flag_hash,
- mi_opt_hash = opt_hash,
- mi_hpc_hash = hpc_hash,
- mi_plugin_hash = plugin_hash,
- mi_orphan = orphan,
- mi_finsts = hasFamInsts,
mi_deps = deps,
mi_usages = usages,
mi_exports = exports,
- mi_exp_hash = exp_hash,
mi_used_th = used_th,
mi_fixities = fixities,
mi_warns = warns,
@@ -1061,14 +1123,25 @@ instance Binary ModIface where
mi_insts = insts,
mi_fam_insts = fam_insts,
mi_rules = rules,
- mi_orphan_hash = orphan_hash,
mi_hpc = hpc_info,
mi_trust = trust,
mi_trust_pkg = trust_pkg,
mi_complete_sigs = complete_sigs,
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
- mi_arg_docs = arg_docs }) = do
+ mi_arg_docs = arg_docs,
+ mi_final_exts = ModIfaceBackend {
+ mi_iface_hash = iface_hash,
+ mi_mod_hash = mod_hash,
+ mi_flag_hash = flag_hash,
+ mi_opt_hash = opt_hash,
+ mi_hpc_hash = hpc_hash,
+ mi_plugin_hash = plugin_hash,
+ mi_orphan = orphan,
+ mi_finsts = hasFamInsts,
+ mi_exp_hash = exp_hash,
+ mi_orphan_hash = orphan_hash
+ }}) = do
put_ bh mod
put_ bh sig_of
put_ bh hsc_src
@@ -1137,18 +1210,9 @@ instance Binary ModIface where
mi_module = mod,
mi_sig_of = sig_of,
mi_hsc_src = hsc_src,
- mi_iface_hash = iface_hash,
- mi_mod_hash = mod_hash,
- mi_flag_hash = flag_hash,
- mi_opt_hash = opt_hash,
- mi_hpc_hash = hpc_hash,
- mi_plugin_hash = plugin_hash,
- mi_orphan = orphan,
- mi_finsts = hasFamInsts,
mi_deps = deps,
mi_usages = usages,
mi_exports = exports,
- mi_exp_hash = exp_hash,
mi_used_th = used_th,
mi_anns = anns,
mi_fixities = fixities,
@@ -1158,40 +1222,41 @@ instance Binary ModIface where
mi_insts = insts,
mi_fam_insts = fam_insts,
mi_rules = rules,
- mi_orphan_hash = orphan_hash,
mi_hpc = hpc_info,
mi_trust = trust,
mi_trust_pkg = trust_pkg,
-- And build the cached values
- mi_warn_fn = mkIfaceWarnCache warns,
- mi_fix_fn = mkIfaceFixCache fixities,
- mi_hash_fn = mkIfaceHashCache decls,
mi_complete_sigs = complete_sigs,
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
- mi_arg_docs = arg_docs })
+ mi_arg_docs = arg_docs,
+ mi_final_exts = ModIfaceBackend {
+ mi_iface_hash = iface_hash,
+ mi_mod_hash = mod_hash,
+ mi_flag_hash = flag_hash,
+ mi_opt_hash = opt_hash,
+ mi_hpc_hash = hpc_hash,
+ mi_plugin_hash = plugin_hash,
+ mi_orphan = orphan,
+ mi_finsts = hasFamInsts,
+ mi_exp_hash = exp_hash,
+ mi_orphan_hash = orphan_hash,
+ mi_warn_fn = mkIfaceWarnCache warns,
+ mi_fix_fn = mkIfaceFixCache fixities,
+ mi_hash_fn = mkIfaceHashCache decls
+ }})
-- | The original names declared of a certain module that are exported
type IfaceExport = AvailInfo
--- | Constructs an empty ModIface
-emptyModIface :: Module -> ModIface
-emptyModIface mod
+emptyPartialModIface :: Module -> PartialModIface
+emptyPartialModIface mod
= ModIface { mi_module = mod,
mi_sig_of = Nothing,
- mi_iface_hash = fingerprint0,
- mi_mod_hash = fingerprint0,
- mi_flag_hash = fingerprint0,
- mi_opt_hash = fingerprint0,
- mi_hpc_hash = fingerprint0,
- mi_plugin_hash = fingerprint0,
- mi_orphan = False,
- mi_finsts = False,
mi_hsc_src = HsSrcFile,
mi_deps = noDependencies,
mi_usages = [],
mi_exports = [],
- mi_exp_hash = fingerprint0,
mi_used_th = False,
mi_fixities = [],
mi_warns = NoWarnings,
@@ -1201,18 +1266,33 @@ emptyModIface mod
mi_rules = [],
mi_decls = [],
mi_globals = Nothing,
- mi_orphan_hash = fingerprint0,
- mi_warn_fn = emptyIfaceWarnCache,
- mi_fix_fn = emptyIfaceFixCache,
- mi_hash_fn = emptyIfaceHashCache,
mi_hpc = False,
mi_trust = noIfaceTrustInfo,
mi_trust_pkg = False,
mi_complete_sigs = [],
mi_doc_hdr = Nothing,
mi_decl_docs = emptyDeclDocMap,
- mi_arg_docs = emptyArgDocMap }
-
+ mi_arg_docs = emptyArgDocMap,
+ mi_final_exts = () }
+
+emptyFullModIface :: Module -> ModIface
+emptyFullModIface mod =
+ (emptyPartialModIface mod)
+ { mi_decls = []
+ , mi_final_exts = ModIfaceBackend
+ { mi_iface_hash = fingerprint0,
+ mi_mod_hash = fingerprint0,
+ mi_flag_hash = fingerprint0,
+ mi_opt_hash = fingerprint0,
+ mi_hpc_hash = fingerprint0,
+ mi_plugin_hash = fingerprint0,
+ mi_orphan = False,
+ mi_finsts = False,
+ mi_exp_hash = fingerprint0,
+ mi_orphan_hash = fingerprint0,
+ mi_warn_fn = emptyIfaceWarnCache,
+ mi_fix_fn = emptyIfaceFixCache,
+ mi_hash_fn = emptyIfaceHashCache } }
-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]
@@ -3153,3 +3233,14 @@ phaseForeignLanguage phase = case phase of
Phase.As _ -> Just LangAsm
Phase.MergeForeign -> Just RawObject
_ -> Nothing
+
+-------------------------------------------
+
+-- Take care, this instance only forces to the degree necessary to
+-- 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) =
+ 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