summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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)
View Lorry Controller Status