summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
authorÖmer Sinan Ağacan <omeragacan@gmail.com>2019-08-21 17:31:49 +0300
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-09-30 22:39:53 -0400
commitf3cb8c7cb99e05feb0f62f5a076400dcf9f930a0 (patch)
tree9f3ec4b8040bcfb0b48a71367199a5f9ad46b768 /compiler/iface
parentce64b397777408731c6dd3f5c55ea8415f9f565b (diff)
downloadhaskell-f3cb8c7cb99e05feb0f62f5a076400dcf9f930a0.tar.gz
Refactor iface file generation:
This commit refactors interface file generation to allow information from the later passed (NCG, STG) to be stored in interface files. We achieve this by splitting interface file generation into two parts: * Partial interfaces, built based on the result of the core pipeline * A fully instantiated interface, which also contains the final fingerprints and can optionally contain information produced by the backend. This change is required by !1304 and !1530. -dynamic-too handling is refactored too: previously when generating code we'd branch on -dynamic-too *before* code generation, but now we do it after. (Original code written by @AndreasK in !1530) Performance ~~~~~~~~~~~ Before this patch interface files where created and immediately flushed to disk which made space leaks impossible. With this change we instead use NFData to force all iface related data structures to avoid space leaks. In the process of refactoring it was discovered that the code in the ToIface Module allocated a lot of thunks which were immediately forced when writing/forcing the interface file. So we made this module more strict to avoid creating many of those thunks. Bottom line is that allocations go down by about ~0.1% compared to master. Residency is not meaningfully different after this patch. Runtime was not benchmarked. Co-Authored-By: Andreas Klebinger <klebinger.andreas@gmx.at> Co-Authored-By: Ömer Sinan Ağacan <omer@well-typed.com>
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/IfaceSyn.hs177
-rw-r--r--compiler/iface/IfaceType.hs74
-rw-r--r--compiler/iface/LoadIface.hs37
-rw-r--r--compiler/iface/MkIface.hs265
-rw-r--r--compiler/iface/ToIface.hs27
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