diff options
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/deSugar/DsUsage.hs | 8 | ||||
-rw-r--r-- | compiler/iface/IfaceSyn.hs | 177 | ||||
-rw-r--r-- | compiler/iface/IfaceType.hs | 74 | ||||
-rw-r--r-- | compiler/iface/LoadIface.hs | 37 | ||||
-rw-r--r-- | compiler/iface/MkIface.hs | 265 | ||||
-rw-r--r-- | compiler/iface/ToIface.hs | 27 | ||||
-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 | ||||
-rw-r--r-- | compiler/rename/RnEnv.hs | 6 | ||||
-rw-r--r-- | compiler/rename/RnFixity.hs | 2 | ||||
-rw-r--r-- | compiler/rename/RnNames.hs | 4 | ||||
-rw-r--r-- | compiler/typecheck/FamInst.hs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcBackpack.hs | 6 | ||||
-rw-r--r-- | compiler/typecheck/TcHoleErrors.hs | 2 | ||||
-rw-r--r-- | compiler/utils/FastString.hs | 3 |
17 files changed, 812 insertions, 386 deletions
diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs index 7c8e24bbec..f5f63934a3 100644 --- a/compiler/deSugar/DsUsage.hs +++ b/compiler/deSugar/DsUsage.hs @@ -319,10 +319,10 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names -- modules accumulate in the PIT not HPT. Sigh. Just iface = maybe_iface - finsts_mod = mi_finsts iface - hash_env = mi_hash_fn iface - mod_hash = mi_mod_hash iface - export_hash | depend_on_exports = Just (mi_exp_hash iface) + finsts_mod = mi_finsts (mi_final_exts iface) + hash_env = mi_hash_fn (mi_final_exts iface) + mod_hash = mi_mod_hash (mi_final_exts iface) + export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface)) | otherwise = Nothing by_is_safe (ImportedByUser imv) = imv_is_safe imv diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index f86ca458d7..ce4332c27b 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -4,6 +4,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} module IfaceSyn ( module IfaceType, @@ -70,9 +71,11 @@ import Util( dropList, filterByList, notNull, unzipWith ) import DataCon (SrcStrictness(..), SrcUnpackedness(..)) import Lexeme (isLexSym) import TysWiredIn ( constraintKindTyConName ) +import Util (seqList) import Control.Monad import System.IO.Unsafe +import Control.DeepSeq infixl 3 &&& @@ -2414,3 +2417,177 @@ instance Binary IfaceTyConParent where instance Binary IfaceCompleteMatch where put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts get bh = IfaceCompleteMatch <$> get bh <*> get bh + + +{- +************************************************************************ +* * + NFData instances + See Note [Avoiding space leaks in toIface*] in ToIface +* * +************************************************************************ +-} + +instance NFData IfaceDecl where + rnf = \case + IfaceId f1 f2 f3 f4 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + + IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 -> + f1 `seq` seqList f2 `seq` f3 `seq` f4 `seq` f5 `seq` + rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9 + + IfaceSynonym f1 f2 f3 f4 f5 -> + rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 + + IfaceFamily f1 f2 f3 f4 f5 f6 -> + rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` f6 `seq` () + + IfaceClass f1 f2 f3 f4 f5 -> + rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 + + IfaceAxiom nm tycon role ax -> + rnf nm `seq` + rnf tycon `seq` + role `seq` + rnf ax + + IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` f6 `seq` + rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` f11 `seq` () + +instance NFData IfaceAxBranch where + rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7 + +instance NFData IfaceClassBody where + rnf = \case + IfAbstractClass -> () + IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () + +instance NFData IfaceAT where + rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2 + +instance NFData IfaceClassOp where + rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` f3 `seq` () + +instance NFData IfaceTyConParent where + rnf = \case + IfNoParent -> () + IfDataInstance f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + +instance NFData IfaceConDecls where + rnf = \case + IfAbstractTyCon -> () + IfDataTyCon f1 -> rnf f1 + IfNewTyCon f1 -> rnf f1 + +instance NFData IfaceConDecl where + rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` + rnf f7 `seq` rnf f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 + +instance NFData IfaceSrcBang where + rnf (IfSrcBang f1 f2) = f1 `seq` f2 `seq` () + +instance NFData IfaceBang where + rnf x = x `seq` () + +instance NFData IfaceIdDetails where + rnf = \case + IfVanillaId -> () + IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b + IfRecSelId (Right decl) b -> rnf decl `seq` rnf b + IfDFunId -> () + +instance NFData IfaceIdInfo where + rnf = \case + NoInfo -> () + HasInfo f1 -> rnf f1 + +instance NFData IfaceInfoItem where + rnf = \case + HsArity a -> rnf a + HsStrictness str -> seqStrictSig str + HsInline p -> p `seq` () -- TODO: seq further? + HsUnfold b unf -> rnf b `seq` rnf unf + HsNoCafRefs -> () + HsLevity -> () + +instance NFData IfaceUnfolding where + rnf = \case + IfCoreUnfold inlinable expr -> + rnf inlinable `seq` rnf expr + IfCompulsory expr -> + rnf expr + IfInlineRule arity b1 b2 e -> + rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e + IfDFunUnfold bndrs exprs -> + rnf bndrs `seq` rnf exprs + +instance NFData IfaceExpr where + rnf = \case + IfaceLcl nm -> rnf nm + IfaceExt nm -> rnf nm + IfaceType ty -> rnf ty + IfaceCo co -> rnf co + IfaceTuple sort exprs -> sort `seq` rnf exprs + IfaceLam bndr expr -> rnf bndr `seq` rnf expr + IfaceApp e1 e2 -> rnf e1 `seq` rnf e2 + IfaceCase e nm alts -> rnf e `seq` nm `seq` rnf alts + IfaceECase e ty -> rnf e `seq` rnf ty + IfaceLet bind e -> rnf bind `seq` rnf e + IfaceCast e co -> rnf e `seq` rnf co + IfaceLit l -> l `seq` () -- FIXME + IfaceFCall fc ty -> fc `seq` rnf ty + IfaceTick tick e -> rnf tick `seq` rnf e + +instance NFData IfaceBinding where + rnf = \case + IfaceNonRec bndr e -> rnf bndr `seq` rnf e + IfaceRec binds -> rnf binds + +instance NFData IfaceLetBndr where + rnf (IfLetBndr nm ty id_info join_info) = + rnf nm `seq` rnf ty `seq` rnf id_info `seq` rnf join_info + +instance NFData IfaceFamTyConFlav where + rnf = \case + IfaceDataFamilyTyCon -> () + IfaceOpenSynFamilyTyCon -> () + IfaceClosedSynFamilyTyCon f1 -> rnf f1 + IfaceAbstractClosedSynFamilyTyCon -> () + IfaceBuiltInSynFamTyCon -> () + +instance NFData IfaceJoinInfo where + rnf x = x `seq` () + +instance NFData IfaceTickish where + rnf = \case + IfaceHpcTick m i -> rnf m `seq` rnf i + IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2 + IfaceSource src str -> src `seq` rnf str + +instance NFData IfaceConAlt where + rnf = \case + IfaceDefault -> () + IfaceDataAlt nm -> rnf nm + IfaceLitAlt lit -> lit `seq` () + +instance NFData IfaceCompleteMatch where + rnf (IfaceCompleteMatch f1 f2) = rnf f1 `seq` rnf f2 + +instance NFData IfaceRule where + rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) = + rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` f8 `seq` () + +instance NFData IfaceFamInst where + rnf (IfaceFamInst f1 f2 f3 f4) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () + +instance NFData IfaceClsInst where + rnf (IfaceClsInst f1 f2 f3 f4 f5) = + f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` () + +instance NFData IfaceAnnotation where + rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` () diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index e3362b7a68..acf116169e 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -9,6 +9,7 @@ This module defines interface types and binders {-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} -- FlexibleInstances for Binary (DefMethSpec IfaceType) module IfaceType ( @@ -79,6 +80,7 @@ import Util import Data.Maybe( isJust ) import qualified Data.Semigroup as Semi +import Control.DeepSeq {- ************************************************************************ @@ -1959,3 +1961,75 @@ instance Binary (DefMethSpec IfaceType) where case h of 0 -> return VanillaDM _ -> do { t <- get bh; return (GenericDM t) } + +instance NFData IfaceType where + rnf = \case + IfaceFreeTyVar f1 -> f1 `seq` () + IfaceTyVar f1 -> rnf f1 + IfaceLitTy f1 -> rnf f1 + IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2 + IfaceFunTy f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceForAllTy f1 f2 -> f1 `seq` rnf f2 + IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2 + IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2 + IfaceCoercionTy f1 -> rnf f1 + IfaceTupleTy f1 f2 f3 -> f1 `seq` f2 `seq` rnf f3 + +instance NFData IfaceTyLit where + rnf = \case + IfaceNumTyLit f1 -> rnf f1 + IfaceStrTyLit f1 -> rnf f1 + +instance NFData IfaceCoercion where + rnf = \case + IfaceReflCo f1 -> rnf f1 + IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceFunCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceForAllCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceCoVarCo f1 -> rnf f1 + IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 + IfaceSymCo f1 -> rnf f1 + IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceNthCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceLRCo f1 f2 -> f1 `seq` rnf f2 + IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceKindCo f1 -> rnf f1 + IfaceSubCo f1 -> rnf f1 + IfaceFreeCoVar f1 -> f1 `seq` () + IfaceHoleCo f1 -> f1 `seq` () + +instance NFData IfaceUnivCoProv where + rnf x = seq x () + +instance NFData IfaceMCoercion where + rnf x = seq x () + +instance NFData IfaceOneShot where + rnf x = seq x () + +instance NFData IfaceTyConSort where + rnf = \case + IfaceNormalTyCon -> () + IfaceTupleTyCon arity sort -> rnf arity `seq` sort `seq` () + IfaceSumTyCon arity -> rnf arity + IfaceEqualityTyCon -> () + +instance NFData IfaceTyConInfo where + rnf (IfaceTyConInfo f s) = f `seq` rnf s + +instance NFData IfaceTyCon where + rnf (IfaceTyCon nm info) = rnf nm `seq` rnf info + +instance NFData IfaceBndr where + rnf = \case + IfaceIdBndr id_bndr -> rnf id_bndr + IfaceTvBndr tv_bndr -> rnf tv_bndr + +instance NFData IfaceAppArgs where + rnf = \case + IA_Nil -> () + IA_Arg f1 f2 f3 -> rnf f1 `seq` f2 `seq` rnf f3 diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index f501e0354b..446477d018 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -7,6 +7,7 @@ Loading interface files -} {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module LoadIface ( -- Importing one thing @@ -422,7 +423,7 @@ loadInterface doc_str mod from Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod ; case read_result of { Failed err -> do - { let fake_iface = emptyModIface mod + { let fake_iface = emptyFullModIface mod ; updateEps_ $ \eps -> eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } @@ -965,7 +966,7 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file r <- read_file dynFilePath case r of Succeeded (dynIface, _) - | mi_mod_hash iface == mi_mod_hash dynIface -> + | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) -> return () | otherwise -> do traceIf (text "Dynamic hash doesn't match") @@ -1039,13 +1040,15 @@ initExternalPackageState ghcPrimIface :: ModIface ghcPrimIface - = (emptyModIface gHC_PRIM) { + = empty_iface { mi_exports = ghcPrimExports, mi_decls = [], mi_fixities = fixities, - mi_fix_fn = mkIfaceFixCache fixities - } + mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities } + } where + empty_iface = emptyFullModIface gHC_PRIM + -- The fixities listed here for @`seq`@ or @->@ should match -- those in primops.txt.pp (from which Haddock docs are generated). fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR) @@ -1118,21 +1121,21 @@ pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ ne pprModIface :: ModIface -> SDoc -- Show a ModIface -pprModIface iface +pprModIface iface@ModIface{ mi_final_exts = exts } = vcat [ text "interface" <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) - <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty) - <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty) - <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty) + <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty) + <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty) + <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty) <+> integer hiVersion - , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface)) - , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) - , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface)) - , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) - , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface)) - , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash iface)) - , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash iface)) - , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash iface)) + , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts)) + , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts)) + , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts)) + , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts)) + , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts)) + , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts)) + , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts)) + , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts)) , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) , nest 2 (text "where") diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 7e555ed45c..296e72a814 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -10,8 +10,8 @@ -- writing them to disk and comparing two versions to see if -- recompilation is required. module MkIface ( - mkIface, -- Build a ModIface from a ModGuts, - -- including computing version information + mkPartialIface, + mkFullIface, mkIfaceTc, @@ -135,48 +135,51 @@ import qualified Data.Semigroup ************************************************************************ -} -mkIface :: HscEnv - -> Maybe Fingerprint -- The old fingerprint, if we have it - -> ModDetails -- The trimmed, tidied interface - -> ModGuts -- Usages, deprecations, etc - -> IO (ModIface, -- The new one - Bool) -- True <=> there was an old Iface, and the - -- new one is identical, so no need - -- to write it - -mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, - mg_hsc_src = hsc_src, - mg_usages = usages, - mg_used_th = used_th, - mg_deps = deps, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_hpc_info = hpc_info, - mg_safe_haskell = safe_mode, - mg_trust_pkg = self_trust, - mg_doc_hdr = doc_hdr, - mg_decl_docs = decl_docs, - mg_arg_docs = arg_docs - } - = mkIface_ hsc_env maybe_old_fingerprint - this_mod hsc_src used_th deps rdr_env fix_env - warns hpc_info self_trust - safe_mode usages - doc_hdr decl_docs arg_docs - mod_details +mkPartialIface :: HscEnv + -> ModDetails + -> ModGuts + -> PartialModIface +mkPartialIface hsc_env mod_details + ModGuts{ mg_module = this_mod + , mg_hsc_src = hsc_src + , mg_usages = usages + , mg_used_th = used_th + , mg_deps = deps + , mg_rdr_env = rdr_env + , mg_fix_env = fix_env + , mg_warns = warns + , mg_hpc_info = hpc_info + , mg_safe_haskell = safe_mode + , mg_trust_pkg = self_trust + , mg_doc_hdr = doc_hdr + , mg_decl_docs = decl_docs + , mg_arg_docs = arg_docs + } + = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust + safe_mode usages doc_hdr decl_docs arg_docs mod_details + +-- | Fully instantiate a interface +-- Adds fingerprints and potentially code generator produced information. +mkFullIface :: HscEnv -> PartialModIface -> IO ModIface +mkFullIface hsc_env partial_iface = do + full_iface <- + {-# SCC "addFingerprints" #-} + addFingerprints hsc_env partial_iface (mi_decls partial_iface) + + -- Debug printing + dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" (pprModIface full_iface) --- | make an interface from the results of typechecking only. Useful + return full_iface + +-- | Make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('HscNothing'). mkIfaceTc :: HscEnv - -> Maybe Fingerprint -- The old fingerprint, if we have it -> SafeHaskellMode -- The safe haskell mode -> ModDetails -- gotten from mkBootModDetails, probably -> TcGblEnv -- Usages, deprecations, etc - -> IO (ModIface, Bool) -mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details + -> IO ModIface +mkIfaceTc hsc_env safe_mode mod_details tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, tcg_imports = imports, @@ -210,7 +213,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details let (doc_hdr', doc_map, arg_map) = extractDocs tc_result - mkIface_ hsc_env maybe_old_fingerprint + let partial_iface = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info @@ -218,9 +221,9 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details doc_hdr' doc_map arg_map mod_details + mkFullIface hsc_env partial_iface - -mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource +mkIface_ :: HscEnv -> Module -> HscSource -> Bool -> Dependencies -> GlobalRdrEnv -> NameEnv FixItem -> Warnings -> HpcInfo -> Bool @@ -230,8 +233,8 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource -> DeclDocMap -> ArgDocMap -> ModDetails - -> IO (ModIface, Bool) -mkIface_ hsc_env maybe_old_fingerprint + -> PartialModIface +mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env src_warns hpc_info pkg_trust_req safe_mode usages doc_hdr decl_docs arg_docs @@ -277,72 +280,38 @@ mkIface_ hsc_env maybe_old_fingerprint annotations = map mkIfaceAnnotation anns icomplete_sigs = map mkIfaceCompleteSig complete_sigs - intermediate_iface = ModIface { - mi_module = this_mod, - -- Need to record this because it depends on the -instantiated-with flag - -- which could change - mi_sig_of = if semantic_mod == this_mod - then Nothing - else Just semantic_mod, - mi_hsc_src = hsc_src, - mi_deps = deps, - mi_usages = usages, - mi_exports = mkIfaceExports exports, - - -- Sort these lexicographically, so that - -- the result is stable across compilations - mi_insts = sortBy cmp_inst iface_insts, - mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts, - mi_rules = sortBy cmp_rule iface_rules, - - mi_fixities = fixities, - mi_warns = warns, - mi_anns = annotations, - mi_globals = maybeGlobalRdrEnv rdr_env, - - -- Left out deliberately: filled in by addFingerprints - mi_iface_hash = fingerprint0, - mi_mod_hash = fingerprint0, - mi_flag_hash = fingerprint0, - mi_opt_hash = fingerprint0, - mi_hpc_hash = fingerprint0, - mi_exp_hash = fingerprint0, - mi_plugin_hash = fingerprint0, - mi_used_th = used_th, - mi_orphan_hash = fingerprint0, - mi_orphan = False, -- Always set by addFingerprints, but - -- it's a strict field, so we can't omit it. - mi_finsts = False, -- Ditto - mi_decls = deliberatelyOmitted "decls", - mi_hash_fn = deliberatelyOmitted "hash_fn", - mi_hpc = isHpcUsed hpc_info, - mi_trust = trust_info, - mi_trust_pkg = pkg_trust_req, - - -- And build the cached values - mi_warn_fn = mkIfaceWarnCache warns, - mi_fix_fn = mkIfaceFixCache fixities, - mi_complete_sigs = icomplete_sigs, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs } - - (new_iface, no_change_at_all) - <- {-# SCC "versioninfo" #-} - addFingerprints hsc_env maybe_old_fingerprint - intermediate_iface decls - - -- Debug printing - dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" - (pprModIface new_iface) - - -- bug #1617: on reload we weren't updating the PrintUnqualified - -- correctly. This stems from the fact that the interface had - -- not changed, so addFingerprints returns the old ModIface - -- with the old GlobalRdrEnv (mi_globals). - let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env } - - return (final_iface, no_change_at_all) + ModIface { + mi_module = this_mod, + -- Need to record this because it depends on the -instantiated-with flag + -- which could change + mi_sig_of = if semantic_mod == this_mod + then Nothing + else Just semantic_mod, + mi_hsc_src = hsc_src, + mi_deps = deps, + mi_usages = usages, + mi_exports = mkIfaceExports exports, + + -- Sort these lexicographically, so that + -- the result is stable across compilations + mi_insts = sortBy cmp_inst iface_insts, + mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts, + mi_rules = sortBy cmp_rule iface_rules, + + mi_fixities = fixities, + mi_warns = warns, + mi_anns = annotations, + mi_globals = maybeGlobalRdrEnv rdr_env, + mi_used_th = used_th, + mi_decls = decls, + mi_hpc = isHpcUsed hpc_info, + mi_trust = trust_info, + mi_trust_pkg = pkg_trust_req, + mi_complete_sigs = icomplete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs, + mi_final_exts = () } where cmp_rule = comparing ifRuleName -- Compare these lexicographically by OccName, *not* by unique, @@ -363,9 +332,6 @@ mkIface_ hsc_env maybe_old_fingerprint | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env | otherwise = Nothing - deliberatelyOmitted :: String -> a - deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) - ifFamInstTcName = ifFamInstFam ----------------------------- @@ -409,7 +375,7 @@ mkHashFun hsc_env eps name iface <- initIfaceLoad hsc_env . withException $ loadInterface (text "lookupVers2") mod ImportBySystem return iface - return $ snd (mi_hash_fn iface occ `orElse` + return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse` pprPanic "lookupVers1" (ppr mod <+> ppr occ)) -- --------------------------------------------------------------------------- @@ -443,17 +409,16 @@ thing that we are currently fingerprinting. -- See Note [Fingerprinting IfaceDecls] addFingerprints :: HscEnv - -> Maybe Fingerprint -- the old fingerprint, if any - -> ModIface -- The new interface (lacking decls) + -> PartialModIface -- The new interface (lacking decls) -> [IfaceDecl] -- The new decls - -> IO (ModIface, -- Updated interface - Bool) -- True <=> no changes at all; - -- no need to write Iface - -addFingerprints hsc_env mb_old_fingerprint iface0 new_decls + -> IO ModIface -- Updated interface +addFingerprints hsc_env iface0 new_decls = do eps <- hscEPS hsc_env let + warn_fn = mkIfaceWarnCache (mi_warns iface0) + fix_fn = mkIfaceFixCache (mi_fixities iface0) + -- The ABI of a declaration represents everything that is made -- visible about the declaration that a client can depend on. -- see IfaceDeclABI below. @@ -719,26 +684,27 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls mi_hpc iface0) let - no_change_at_all = Just iface_hash == mb_old_fingerprint - - final_iface = iface0 { - mi_mod_hash = mod_hash, - mi_iface_hash = iface_hash, - mi_exp_hash = export_hash, - mi_orphan_hash = orphan_hash, - mi_flag_hash = flag_hash, - mi_opt_hash = opt_hash, - mi_hpc_hash = hpc_hash, - mi_plugin_hash = plugin_hash, - mi_orphan = not ( all ifRuleAuto orph_rules - -- See Note [Orphans and auto-generated rules] - && null orph_insts - && null orph_fis), - mi_finsts = not . null $ mi_fam_insts iface0, - mi_decls = sorted_decls, - mi_hash_fn = lookupOccEnv local_env } + final_iface_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 = not ( all ifRuleAuto orph_rules + -- See Note [Orphans and auto-generated rules] + && null orph_insts + && null orph_fis) + , mi_finsts = not (null (mi_fam_insts iface0)) + , mi_exp_hash = export_hash + , mi_orphan_hash = orphan_hash + , mi_warn_fn = warn_fn + , mi_fix_fn = fix_fn + , mi_hash_fn = lookupOccEnv local_env + } + final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts } -- - return (final_iface, no_change_at_all) + return final_iface where this_mod = mi_module iface0 @@ -747,7 +713,6 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) - fix_fn = mi_fix_fn iface0 ann_fn = mkIfaceAnnCache (mi_anns iface0) -- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules @@ -789,11 +754,11 @@ getOrphanHashes hsc_env mods = do dflags = hsc_dflags hsc_env get_orph_hash mod = case lookupIfaceByModule dflags hpt pit mod of - Just iface -> return (mi_orphan_hash iface) + Just iface -> return (mi_orphan_hash (mi_final_exts iface)) Nothing -> do -- similar to 'mkHashFun' iface <- initIfaceLoad hsc_env . withException $ loadInterface (text "getOrphanHashes") mod ImportBySystem - return (mi_orphan_hash iface) + return (mi_orphan_hash (mi_final_exts iface)) -- mapM get_orph_hash mods @@ -1327,7 +1292,7 @@ checkVersions hsc_env mod_summary iface checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired checkPlugins hsc iface = liftIO $ do new_fingerprint <- fingerprintPlugins hsc - let old_fingerprint = mi_plugin_hash iface + let old_fingerprint = mi_plugin_hash (mi_final_exts iface) pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc)) return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr @@ -1424,7 +1389,7 @@ checkHie mod_summary = do -- | Check the flags haven't changed checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do - let old_hash = mi_flag_hash iface + let old_hash = mi_flag_hash (mi_final_exts iface) new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) (mi_module iface) putNameLiterally @@ -1437,7 +1402,7 @@ checkFlagHash hsc_env iface = do -- | Check the optimisation flags haven't changed checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired checkOptimHash hsc_env iface = do - let old_hash = mi_opt_hash iface + let old_hash = mi_opt_hash (mi_final_exts iface) new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env) putNameLiterally if | old_hash == new_hash @@ -1452,7 +1417,7 @@ checkOptimHash hsc_env iface = do -- | Check the HPC flags haven't changed checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired checkHpcHash hsc_env iface = do - let old_hash = mi_hpc_hash iface + let old_hash = mi_hpc_hash (mi_final_exts iface) new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env) putNameLiterally if | old_hash == new_hash @@ -1635,7 +1600,7 @@ checkModUsage _this_pkg UsagePackageModule{ usg_mod_hash = old_mod_hash } = needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed" - checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) + checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) -- We only track the ABI hash of package modules, rather than -- individual entity usages, so if the ABI hash changes we must -- recompile. This is safe but may entail more recompilation when @@ -1644,7 +1609,7 @@ checkModUsage _this_pkg UsagePackageModule{ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed (raw)" - checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) + checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) checkModUsage this_pkg UsageHomeModule{ usg_mod_name = mod_name, @@ -1656,9 +1621,9 @@ checkModUsage this_pkg UsageHomeModule{ needInterface mod $ \iface -> do let - new_mod_hash = mi_mod_hash iface - new_decl_hash = mi_hash_fn iface - new_export_hash = mi_exp_hash iface + new_mod_hash = mi_mod_hash (mi_final_exts iface) + new_decl_hash = mi_hash_fn (mi_final_exts iface) + new_export_hash = mi_exp_hash (mi_final_exts iface) reason = moduleNameString mod_name ++ " changed" diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs index f20fed214a..d32a0529af 100644 --- a/compiler/iface/ToIface.hs +++ b/compiler/iface/ToIface.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] -- | Functions for converting Core things to interface file things. module ToIface @@ -73,6 +74,32 @@ import Demand ( isTopSig ) import Data.Maybe ( catMaybes ) +{- Note [Avoiding space leaks in toIface*] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Building a interface file depends on the output of the simplifier. +If we build these lazily this would mean keeping the Core AST alive +much longer than necessary causing a space "leak". + +This happens for example when we only write the interface file to disk +after code gen has run, in which case we might carry megabytes of core +AST in the heap which is no longer needed. + +We avoid this in two ways. +* First we use -XStrict in ToIface which avoids many thunks to begin with. +* Second we define NFData instance for IFaceSyn and use them to + force any remaining thunks. + +-XStrict is not sufficient as patterns of the form `f (g x)` would still +result in a thunk being allocated for `g x`. + +NFData is sufficient for the space leak, but using -XStrict reduces allocation +by ~0.1% when compiling with -O. (nofib/spectral/simple, T10370). +It's essentially free performance hence we use -XStrict on top of NFData. + +MR !1633 on gitlab, has more discussion on the topic. +-} + ---------------- toIfaceTvBndr :: TyVar -> IfaceTvBndr toIfaceTvBndr = toIfaceTvBndrX emptyVarSet 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 diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index d9dbbee891..c84e7bd328 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1266,10 +1266,10 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt lookupImpDeprec iface gre - = mi_warn_fn iface (greOccName gre) `mplus` -- Bleat if the thing, + = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, case gre_par gre of -- or its parent, is warn'd - ParentIs p -> mi_warn_fn iface (nameOccName p) - FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p) + ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p) + FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p) NoParent -> Nothing {- diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs index 198a0441e5..68d1348871 100644 --- a/compiler/rename/RnFixity.hs +++ b/compiler/rename/RnFixity.hs @@ -157,7 +157,7 @@ lookupFixityRn_help' name occ -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. = do { iface <- loadInterfaceForName doc name - ; let mb_fix = mi_fix_fn iface occ + ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ ; let msg = case mb_fix of Nothing -> text "looking up name" <+> ppr name diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 738f4c6ab5..7b9a385e48 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -393,8 +393,8 @@ calculateAvails :: DynFlags calculateAvails dflags iface mod_safe' want_boot imported_by = let imp_mod = mi_module iface imp_sem_mod= mi_semantic_module iface - orph_iface = mi_orphan iface - has_finsts = mi_finsts iface + orph_iface = mi_orphan (mi_final_exts iface) + has_finsts = mi_finsts (mi_final_exts iface) deps = mi_deps iface trust = getSafeMode $ mi_trust iface trust_pkg = mi_trust_pkg iface diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index bcc91e01de..a339dd7b57 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -319,7 +319,7 @@ checkFamInstConsistency directlyImpMods -- Note [Checking family instance optimization] ; modConsistent :: Module -> [Module] ; modConsistent mod = - if mi_finsts (modIface mod) then mod:deps else deps + if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps where deps = dep_finsts . mi_deps . modIface $ mod diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index 1e9a1ea691..f756a7715a 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -91,7 +91,7 @@ checkHsigDeclM sig_iface sig_thing real_thing = do -- implementation cases. checkBootDeclM False sig_thing real_thing real_fixity <- lookupFixityRn name - let sig_fixity = case mi_fix_fn sig_iface (occName name) of + let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of Nothing -> defaultFixity Just f -> f when (real_fixity /= sig_fixity) $ @@ -832,7 +832,7 @@ mergeSignatures -- This is a HACK to prevent calculateAvails from including imp_mod -- in the listing. We don't want it because a module is NOT -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 - iface' = iface { mi_orphan = False, mi_finsts = False } + iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } avails = plusImportAvails (tcg_imports tcg_env) $ calculateAvails dflags iface' False False ImportedBySystem return tcg_env { @@ -843,7 +843,7 @@ mergeSignatures if outer_mod == mi_module iface -- Don't add ourselves! then tcg_merged tcg_env - else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env + else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env } -- Note [Signature merging DFuns] diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs index bf3253188b..3366e5a1ad 100644 --- a/compiler/typecheck/TcHoleErrors.hs +++ b/compiler/typecheck/TcHoleErrors.hs @@ -51,7 +51,7 @@ import TcUnify ( tcSubType_NC ) import ExtractDocs ( extractDocs ) import qualified Data.Map as Map import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) -import HscTypes ( ModIface(..) ) +import HscTypes ( ModIface_(..) ) import LoadIface ( loadInterfaceForNameMaybe ) import PrelInfo (knownKeyNames) diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs index 7749c3f7c3..8f3d454a1f 100644 --- a/compiler/utils/FastString.hs +++ b/compiler/utils/FastString.hs @@ -224,6 +224,9 @@ instance Data FastString where gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "FastString" +instance NFData FastString where + rnf fs = seq fs () + cmpFS :: FastString -> FastString -> Ordering cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) = if u1 == u2 then EQ else |