diff options
Diffstat (limited to 'compiler/iface')
| -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 |
5 files changed, 413 insertions, 167 deletions
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 |