summaryrefslogtreecommitdiff
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
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>
-rw-r--r--compiler/deSugar/DsUsage.hs8
-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
-rw-r--r--compiler/main/DriverPipeline.hs97
-rw-r--r--compiler/main/GHC.hs2
-rw-r--r--compiler/main/HscMain.hs223
-rw-r--r--compiler/main/HscTypes.hs263
-rw-r--r--compiler/rename/RnEnv.hs6
-rw-r--r--compiler/rename/RnFixity.hs2
-rw-r--r--compiler/rename/RnNames.hs4
-rw-r--r--compiler/typecheck/FamInst.hs2
-rw-r--r--compiler/typecheck/TcBackpack.hs6
-rw-r--r--compiler/typecheck/TcHoleErrors.hs2
-rw-r--r--compiler/utils/FastString.hs3
-rw-r--r--ghc/Main.hs2
18 files changed, 813 insertions, 387 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
diff --git a/ghc/Main.hs b/ghc/Main.hs
index ea320be40f..d53c71a779 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -903,7 +903,7 @@ abiHash strs = do
put_ bh hiVersion
-- package hashes change when the compiler version changes (for now)
-- see #5328
- mapM_ (put_ bh . mi_mod_hash) ifaces
+ mapM_ (put_ bh . mi_mod_hash . mi_final_exts) ifaces
f <- fingerprintBinMem bh
putStrLn (showPpr dflags f)