diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 97 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 2 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 223 | ||||
| -rw-r--r-- | compiler/main/HscTypes.hs | 263 |
4 files changed, 381 insertions, 204 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index cc8b70d80e..38403940bd 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 |