summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-02-26 16:45:27 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-03-11 08:17:19 -0400
commit20800b9a9e88a8784a3ee8720544f504aba7b4f7 (patch)
tree2353a93c9979edd08853d74e44db9691911ed947
parentbb586f894532baf1bcb822afd0df7f9fea198671 (diff)
downloadhaskell-20800b9a9e88a8784a3ee8720544f504aba7b4f7.tar.gz
Split GHC.Iface.Utils module
* GHC.Iface.Recomp: recompilation avoidance stuff * GHC.Iface.Make: mkIface* Moved `writeIfaceFile` into GHC.Iface.Load alongside `readIface` and renamed it `writeIface` for consistency.
-rw-r--r--compiler/GHC/Core.hs6
-rw-r--r--compiler/GHC/Core/Ppr/TyThing.hs4
-rw-r--r--compiler/GHC/Driver/Backpack.hs2
-rw-r--r--compiler/GHC/Driver/Main.hs11
-rw-r--r--compiler/GHC/Driver/Pipeline.hs2
-rw-r--r--compiler/GHC/Driver/Types.hs2
-rw-r--r--compiler/GHC/HsToCore/Usage.hs2
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs2
-rw-r--r--compiler/GHC/Iface/Load.hs13
-rw-r--r--compiler/GHC/Iface/Make.hs723
-rw-r--r--compiler/GHC/Iface/Recomp.hs (renamed from compiler/GHC/Iface/Utils.hs)2053
-rw-r--r--compiler/GHC/Iface/Syntax.hs2
-rw-r--r--compiler/ghc.cabal.in3
-rw-r--r--compiler/prelude/PrelInfo.hs2
-rw-r--r--compiler/typecheck/TcRnDriver.hs4
-rw-r--r--compiler/typecheck/TcRnTypes.hs4
-rw-r--r--compiler/types/InstEnv.hs2
17 files changed, 1429 insertions, 1408 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 7a3996364c..7fe26e0f39 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -1276,7 +1276,7 @@ has two major consequences
In contrast, orphans are all fingerprinted together in the
mi_orph_hash field of the ModIface.
- See GHC.Iface.Utils.addFingerprints.
+ See GHC.Iface.Recomp.addFingerprints.
Orphan-hood is computed
* For class instances:
@@ -1284,8 +1284,8 @@ Orphan-hood is computed
(because it is needed during instance lookup)
* For rules and family instances:
- when we generate an IfaceRule (GHC.Iface.Utils.coreRuleToIfaceRule)
- or IfaceFamInst (GHC.Iface.Utils.instanceToIfaceInst)
+ when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule)
+ or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst)
-}
{-
diff --git a/compiler/GHC/Core/Ppr/TyThing.hs b/compiler/GHC/Core/Ppr/TyThing.hs
index b11cd6edb2..6e092498d9 100644
--- a/compiler/GHC/Core/Ppr/TyThing.hs
+++ b/compiler/GHC/Core/Ppr/TyThing.hs
@@ -26,7 +26,7 @@ import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
, showToHeader, pprIfaceDecl )
import CoAxiom ( coAxiomTyCon )
import GHC.Driver.Types( tyThingParent_maybe )
-import GHC.Iface.Utils ( tyThingToIfaceDecl )
+import GHC.Iface.Make ( tyThingToIfaceDecl )
import FamInstEnv( FamInst(..), FamFlavor(..) )
import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType )
import Name
@@ -72,7 +72,7 @@ Why do this?
* Interface files contains fast-strings, not uniques, so the very same
tidying must take place when we convert to IfaceDecl. E.g.
- GHC.Iface.Utils.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,
+ GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,
Class etc) to an IfaceDecl.
Bottom line: IfaceDecls are already 'tidy', so it's straightforward
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index e5364e3d3f..a82c9c562f 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -44,7 +44,7 @@ import UniqDFM
import Outputable
import Maybes
import HeaderInfo
-import GHC.Iface.Utils
+import GHC.Iface.Recomp
import GHC.Driver.Make
import UniqDSet
import PrelNames
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 00eff081ee..844baedce4 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -116,11 +116,12 @@ import GHC.IfaceToCore ( typecheckIface )
import TcRnMonad
import TcHsSyn ( ZonkFlexi (DefaultFlexi) )
import NameCache ( initNameCache )
-import GHC.Iface.Load ( ifaceStats, initExternalPackageState )
import PrelInfo
-import GHC.Iface.Utils
-import GHC.HsToCore
import SimplCore
+import GHC.HsToCore
+import GHC.Iface.Load ( ifaceStats, initExternalPackageState, writeIface )
+import GHC.Iface.Make
+import GHC.Iface.Recomp
import GHC.Iface.Tidy
import GHC.CoreToStg.Prep
import GHC.CoreToStg ( coreToStg )
@@ -1370,7 +1371,7 @@ hscWriteIface dflags iface no_change mod_location = do
unless no_change $
let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags)
in {-# SCC "writeIface" #-}
- writeIfaceFile dflags ifaceFile iface
+ writeIface dflags ifaceFile iface
whenGeneratingDynamicToo dflags $ do
-- TODO: We should do a no_change check for the dynamic
-- interface file too
@@ -1379,7 +1380,7 @@ hscWriteIface dflags iface no_change mod_location = do
-- dynDflags will have set hiSuf correctly.
dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags)
- writeIfaceFile dynDflags dynIfaceFile iface
+ writeIface dynDflags dynIfaceFile iface
where
buildIfName :: String -> String -> String
buildIfName baseName suffix
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index ca6d501be6..7a7448888d 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -68,7 +68,7 @@ import FileCleanup
import Ar
import Bag ( unitBag )
import FastString ( mkFastString )
-import GHC.Iface.Utils ( mkFullIface )
+import GHC.Iface.Make ( mkFullIface )
import UpdateCafInfos ( updateModDetailsCafInfos )
import Exception
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs
index 58fe239900..33a431a8f5 100644
--- a/compiler/GHC/Driver/Types.hs
+++ b/compiler/GHC/Driver/Types.hs
@@ -2513,7 +2513,7 @@ data Dependencies
-- ^ All the plugins used while compiling this module.
}
deriving( Eq )
- -- Equality used only for old/new comparison in GHC.Iface.Utils.addFingerprints
+ -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints
-- See 'TcRnTypes.ImportAvails' for details on dependencies.
instance Binary Dependencies where
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index b83d310e0a..7e278dc07b 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -5,7 +5,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Usage (
- -- * Dependency/fingerprinting code (used by GHC.Iface.Utils)
+ -- * Dependency/fingerprinting code (used by GHC.Iface.Make)
mkUsageInfo, mkUsedNames, mkDependencies
) where
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index cb910d927b..b40454ee38 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -39,7 +39,7 @@ import Type ( mkVisFunTys, Type )
import TysWiredIn ( mkListTy, mkSumTy )
import Var ( Id, Var, setVarName, varName, varType )
import TcRnTypes
-import GHC.Iface.Utils ( mkIfaceExports )
+import GHC.Iface.Make ( mkIfaceExports )
import Panic
import Maybes
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 64b25bee75..829b35d0ec 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -22,7 +22,7 @@ module GHC.Iface.Load (
-- IfM functions
loadInterface,
loadSysInterface, loadUserInterface, loadPluginInterface,
- findAndReadIface, readIface, -- Used when reading the module's old interface
+ findAndReadIface, readIface, writeIface,
loadDecls, -- Should move to GHC.IfaceToCore and be renamed
initExternalPackageState,
moduleFreeHolesPrecise,
@@ -84,6 +84,7 @@ import Control.Monad
import Control.Exception
import Data.IORef
import System.FilePath
+import System.Directory
{-
************************************************************************
@@ -486,7 +487,6 @@ loadInterface doc_str mod from
-- Warn warn against an EPS-updating import
-- of one's own boot file! (one-shot only)
-- See Note [Loading your own hi-boot file]
- -- in GHC.Iface.Utils.
; WARN( bad_boot, ppr mod )
updateEps_ $ \ eps ->
@@ -536,7 +536,7 @@ loadInterface doc_str mod from
Generally speaking, when compiling module M, we should not
load M.hi boot into the EPS. After all, we are very shortly
going to have full information about M. Moreover, see
-Note [Do not update EPS with your own hi-boot] in GHC.Iface.Utils.
+Note [Do not update EPS with your own hi-boot] in GHC.Iface.Recomp.
But there is a HORRIBLE HACK here.
@@ -974,8 +974,13 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
liftIO $ writeIORef ref False
checkBuildDynamicToo _ = return ()
--- @readIface@ tries just the one file.
+-- | Write interface file
+writeIface :: DynFlags -> FilePath -> ModIface -> IO ()
+writeIface dflags hi_file_path new_iface
+ = do createDirectoryIfMissing True (takeDirectory hi_file_path)
+ writeBinIface dflags hi_file_path new_iface
+-- @readIface@ tries just the one file.
readIface :: Module -> FilePath
-> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
-- Failed err <=> file not found, or unreadable, or illegible
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
new file mode 100644
index 0000000000..45a7ee08e6
--- /dev/null
+++ b/compiler/GHC/Iface/Make.hs
@@ -0,0 +1,723 @@
+{-
+(c) The University of Glasgow 2006-2008
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+-}
+
+{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE MultiWayIf #-}
+
+-- | Module for constructing @ModIface@ values (interface files),
+-- writing them to disk and comparing two versions to see if
+-- recompilation is required.
+module GHC.Iface.Make
+ ( mkPartialIface
+ , mkFullIface
+ , mkIfaceTc
+ , mkIfaceExports
+ , coAxiomToIfaceDecl
+ , tyThingToIfaceDecl -- Converting things to their Iface equivalents
+ )
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Iface.Syntax
+import GHC.Iface.Recomp
+import GHC.Iface.Load
+import GHC.CoreToIface
+
+import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )
+import Id
+import Annotations
+import GHC.Core
+import Class
+import TyCon
+import CoAxiom
+import ConLike
+import DataCon
+import Type
+import TcType
+import InstEnv
+import FamInstEnv
+import TcRnMonad
+import GHC.Hs
+import GHC.Driver.Types
+import GHC.Driver.Session
+import VarEnv
+import Var
+import Name
+import Avail
+import RdrName
+import NameEnv
+import NameSet
+import Module
+import ErrUtils
+import Outputable
+import BasicTypes hiding ( SuccessFlag(..) )
+import Util hiding ( eqListBy )
+import FastString
+import Maybes
+import GHC.HsToCore.Docs
+
+import Data.Function
+import Data.List ( findIndex, mapAccumL, sortBy )
+import Data.Ord
+import Data.IORef
+import GHC.Driver.Plugins (LoadedPlugin(..))
+
+{-
+************************************************************************
+* *
+\subsection{Completing an interface}
+* *
+************************************************************************
+-}
+
+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 -> Maybe NameSet -> IO ModIface
+mkFullIface hsc_env partial_iface mb_non_cafs = do
+ let decls
+ | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
+ = mi_decls partial_iface
+ | otherwise
+ = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs
+
+ full_iface <-
+ {-# SCC "addFingerprints" #-}
+ addFingerprints hsc_env partial_iface{ mi_decls = decls }
+
+ -- Debug printing
+ dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)
+
+ return full_iface
+
+updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl]
+updateDeclCafInfos decls Nothing = decls
+updateDeclCafInfos decls (Just non_cafs) = map update_decl decls
+ where
+ update_decl decl
+ | IfaceId nm ty details infos <- decl
+ , elemNameSet nm non_cafs
+ = IfaceId nm ty details (HsNoCafRefs : infos)
+ | otherwise
+ = decl
+
+-- | 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
+ -> SafeHaskellMode -- The safe haskell mode
+ -> ModDetails -- gotten from mkBootModDetails, probably
+ -> TcGblEnv -- Usages, deprecations, etc
+ -> IO ModIface
+mkIfaceTc hsc_env safe_mode mod_details
+ tc_result@TcGblEnv{ tcg_mod = this_mod,
+ tcg_src = hsc_src,
+ tcg_imports = imports,
+ tcg_rdr_env = rdr_env,
+ tcg_fix_env = fix_env,
+ tcg_merged = merged,
+ tcg_warns = warns,
+ tcg_hpc = other_hpc_info,
+ tcg_th_splice_used = tc_splice_used,
+ tcg_dependent_files = dependent_files
+ }
+ = do
+ let used_names = mkUsedNames tc_result
+ let pluginModules =
+ map lpModule (cachedPlugins (hsc_dflags hsc_env))
+ deps <- mkDependencies
+ (thisInstalledUnitId (hsc_dflags hsc_env))
+ (map mi_module pluginModules) tc_result
+ let hpc_info = emptyHpcInfo other_hpc_info
+ used_th <- readIORef tc_splice_used
+ dep_files <- (readIORef dependent_files)
+ -- Do NOT use semantic module here; this_mod in mkUsageInfo
+ -- is used solely to decide if we should record a dependency
+ -- or not. When we instantiate a signature, the semantic
+ -- module is something we want to record dependencies for,
+ -- but if you pass that in here, we'll decide it's the local
+ -- module and does not need to be recorded as a dependency.
+ -- See Note [Identity versus semantic module]
+ usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names
+ dep_files merged pluginModules
+
+ let (doc_hdr', doc_map, arg_map) = extractDocs tc_result
+
+ let partial_iface = mkIface_ hsc_env
+ this_mod hsc_src
+ used_th deps rdr_env
+ fix_env warns hpc_info
+ (imp_trust_own_pkg imports) safe_mode usages
+ doc_hdr' doc_map arg_map
+ mod_details
+
+ mkFullIface hsc_env partial_iface Nothing
+
+mkIface_ :: HscEnv -> Module -> HscSource
+ -> Bool -> Dependencies -> GlobalRdrEnv
+ -> NameEnv FixItem -> Warnings -> HpcInfo
+ -> Bool
+ -> SafeHaskellMode
+ -> [Usage]
+ -> Maybe HsDocString
+ -> DeclDocMap
+ -> ArgDocMap
+ -> ModDetails
+ -> 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
+ ModDetails{ md_insts = insts,
+ md_fam_insts = fam_insts,
+ md_rules = rules,
+ md_anns = anns,
+ md_types = type_env,
+ md_exports = exports,
+ md_complete_sigs = complete_sigs }
+-- NB: notice that mkIface does not look at the bindings
+-- only at the TypeEnv. The previous Tidy phase has
+-- put exactly the info into the TypeEnv that we want
+-- to expose in the interface
+
+ = do
+ let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)
+ entities = typeEnvElts type_env
+ decls = [ tyThingToIfaceDecl entity
+ | entity <- entities,
+ let name = getName entity,
+ not (isImplicitTyThing entity),
+ -- No implicit Ids and class tycons in the interface file
+ not (isWiredInName name),
+ -- Nor wired-in things; the compiler knows about them anyhow
+ nameIsLocalOrFrom semantic_mod name ]
+ -- Sigh: see Note [Root-main Id] in TcRnDriver
+ -- NB: ABSOLUTELY need to check against semantic_mod,
+ -- because all of the names in an hsig p[H=<H>]:H
+ -- are going to be for <H>, not the former id!
+ -- See Note [Identity versus semantic module]
+
+ fixities = sortBy (comparing fst)
+ [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
+ -- The order of fixities returned from nameEnvElts is not
+ -- deterministic, so we sort by OccName to canonicalize it.
+ -- See Note [Deterministic UniqFM] in UniqDFM for more details.
+ warns = src_warns
+ iface_rules = map coreRuleToIfaceRule rules
+ iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
+ iface_fam_insts = map famInstToIfaceFamInst fam_insts
+ trust_info = setSafeMode safe_mode
+ annotations = map mkIfaceAnnotation anns
+ icomplete_sigs = map mkIfaceCompleteSig complete_sigs
+
+ 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,
+ -- because the latter is not stable across compilations:
+ cmp_inst = comparing (nameOccName . ifDFun)
+ cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
+
+ dflags = hsc_dflags hsc_env
+
+ -- We only fill in mi_globals if the module was compiled to byte
+ -- code. Otherwise, the compiler may not have retained all the
+ -- top-level bindings and they won't be in the TypeEnv (see
+ -- Desugar.addExportFlagsAndRules). The mi_globals field is used
+ -- by GHCi to decide whether the module has its full top-level
+ -- scope available. (#5534)
+ maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
+ maybeGlobalRdrEnv rdr_env
+ | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
+ | otherwise = Nothing
+
+ ifFamInstTcName = ifFamInstFam
+
+
+{-
+************************************************************************
+* *
+ COMPLETE Pragmas
+* *
+************************************************************************
+-}
+
+mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
+mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
+
+
+{-
+************************************************************************
+* *
+ Keeping track of what we've slurped, and fingerprints
+* *
+************************************************************************
+-}
+
+
+mkIfaceAnnotation :: Annotation -> IfaceAnnotation
+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })
+ = IfaceAnnotation {
+ ifAnnotatedTarget = fmap nameOccName target,
+ ifAnnotatedValue = payload
+ }
+
+mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical
+mkIfaceExports exports
+ = sortBy stableAvailCmp (map sort_subs exports)
+ where
+ sort_subs :: AvailInfo -> AvailInfo
+ sort_subs (Avail n) = Avail n
+ sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
+ sort_subs (AvailTC n (m:ms) fs)
+ | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
+ | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
+ -- Maintain the AvailTC Invariant
+
+ sort_flds = sortBy (stableNameCmp `on` flSelector)
+
+{-
+Note [Original module]
+~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+ module X where { data family T }
+ module Y( T(..) ) where { import X; data instance T Int = MkT Int }
+The exported Avail from Y will look like
+ X.T{X.T, Y.MkT}
+That is, in Y,
+ - only MkT is brought into scope by the data instance;
+ - but the parent (used for grouping and naming in T(..) exports) is X.T
+ - and in this case we export X.T too
+
+In the result of mkIfaceExports, the names are grouped by defining module,
+so we may need to split up a single Avail into multiple ones.
+
+Note [Internal used_names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Most of the used_names are External Names, but we can have Internal
+Names too: see Note [Binders in Template Haskell] in Convert, and
+#5362 for an example. Such Names are always
+ - Such Names are always for locally-defined things, for which we
+ don't gather usage info, so we can just ignore them in ent_map
+ - They are always System Names, hence the assert, just as a double check.
+
+-}
+
+
+{-
+************************************************************************
+* *
+ Converting things to their Iface equivalents
+* *
+************************************************************************
+-}
+
+tyThingToIfaceDecl :: TyThing -> IfaceDecl
+tyThingToIfaceDecl (AnId id) = idToIfaceDecl id
+tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
+tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax
+tyThingToIfaceDecl (AConLike cl) = case cl of
+ RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
+ PatSynCon ps -> patSynToIfaceDecl ps
+
+--------------------------
+idToIfaceDecl :: Id -> IfaceDecl
+-- The Id is already tidied, so that locally-bound names
+-- (lambdas, for-alls) already have non-clashing OccNames
+-- We can't tidy it here, locally, because it may have
+-- free variables in its type or IdInfo
+idToIfaceDecl id
+ = IfaceId { ifName = getName id,
+ ifType = toIfaceType (idType id),
+ ifIdDetails = toIfaceIdDetails (idDetails id),
+ ifIdInfo = toIfaceIdInfo (idInfo id) }
+
+--------------------------
+dataConToIfaceDecl :: DataCon -> IfaceDecl
+dataConToIfaceDecl dataCon
+ = IfaceId { ifName = getName dataCon,
+ ifType = toIfaceType (dataConUserType dataCon),
+ ifIdDetails = IfVanillaId,
+ ifIdInfo = [] }
+
+--------------------------
+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
+-- We *do* tidy Axioms, because they are not (and cannot
+-- conveniently be) built in tidy form
+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
+ , co_ax_role = role })
+ = IfaceAxiom { ifName = getName ax
+ , ifTyCon = toIfaceTyCon tycon
+ , ifRole = role
+ , ifAxBranches = map (coAxBranchToIfaceBranch tycon
+ (map coAxBranchLHS branch_list))
+ branch_list }
+ where
+ branch_list = fromBranches branches
+
+-- 2nd parameter is the list of branch LHSs, in case of a closed type family,
+-- for conversion from incompatible branches to incompatible indices.
+-- For an open type family the list should be empty.
+-- See Note [Storing compatibility] in CoAxiom
+coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch tc lhs_s
+ (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
+ , cab_eta_tvs = eta_tvs
+ , cab_lhs = lhs, cab_roles = roles
+ , cab_rhs = rhs, cab_incomps = incomps })
+
+ = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs
+ , ifaxbCoVars = map toIfaceIdBndr cvs
+ , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs
+ , ifaxbLHS = toIfaceTcArgs tc lhs
+ , ifaxbRoles = roles
+ , ifaxbRHS = toIfaceType rhs
+ , ifaxbIncomps = iface_incomps }
+ where
+ iface_incomps = map (expectJust "iface_incomps"
+ . flip findIndex lhs_s
+ . eqTypes
+ . coAxBranchLHS) incomps
+
+-----------------
+tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
+-- We *do* tidy TyCons, because they are not (and cannot
+-- conveniently be) built in tidy form
+-- The returned TidyEnv is the one after tidying the tyConTyVars
+tyConToIfaceDecl env tycon
+ | Just clas <- tyConClass_maybe tycon
+ = classToIfaceDecl env clas
+
+ | Just syn_rhs <- synTyConRhs_maybe tycon
+ = ( tc_env1
+ , IfaceSynonym { ifName = getName tycon,
+ ifRoles = tyConRoles tycon,
+ ifSynRhs = if_syn_type syn_rhs,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind
+ })
+
+ | Just fam_flav <- famTyConFlav_maybe tycon
+ = ( tc_env1
+ , IfaceFamily { ifName = getName tycon,
+ ifResVar = if_res_var,
+ ifFamFlav = to_if_fam_flav fam_flav,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind,
+ ifFamInj = tyConInjectivityInfo tycon
+ })
+
+ | isAlgTyCon tycon
+ = ( tc_env1
+ , IfaceData { ifName = getName tycon,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind,
+ ifCType = tyConCType tycon,
+ ifRoles = tyConRoles tycon,
+ ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
+ ifCons = ifaceConDecls (algTyConRhs tycon),
+ ifGadtSyntax = isGadtSyntaxTyCon tycon,
+ ifParent = parent })
+
+ | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
+ -- We only convert these TyCons to IfaceTyCons when we are
+ -- just about to pretty-print them, not because we are going
+ -- to put them into interface files
+ = ( env
+ , IfaceData { ifName = getName tycon,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind,
+ ifCType = Nothing,
+ ifRoles = tyConRoles tycon,
+ ifCtxt = [],
+ ifCons = IfDataTyCon [],
+ ifGadtSyntax = False,
+ ifParent = IfNoParent })
+ where
+ -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`
+ -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
+ -- an error.
+ (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
+ tc_tyvars = binderVars tc_binders
+ if_binders = toIfaceTyCoVarBinders tc_binders
+ -- No tidying of the binders; they are already tidy
+ if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon)
+ if_syn_type ty = tidyToIfaceType tc_env1 ty
+ if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon
+
+ parent = case tyConFamInstSig_maybe tycon of
+ Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
+ (toIfaceTyCon tc)
+ (tidyToIfaceTcArgs tc_env1 tc ty)
+ Nothing -> IfNoParent
+
+ to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
+ to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
+ to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
+ to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
+ to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing
+ to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
+ = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
+ where defs = fromBranches $ coAxiomBranches ax
+ lhss = map coAxBranchLHS defs
+ ibr = map (coAxBranchToIfaceBranch tycon lhss) defs
+ axn = coAxiomName ax
+
+ ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
+ ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
+ ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con]
+ ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
+ ifaceConDecls AbstractTyCon = IfAbstractTyCon
+ -- The AbstractTyCon case happens when a TyCon has been trimmed
+ -- during tidying.
+ -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
+ -- for GHCi, when browsing a module, in which case the
+ -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
+ -- (Tuple declarations are not serialised into interface files.)
+
+ ifaceConDecl data_con
+ = IfCon { ifConName = dataConName data_con,
+ ifConInfix = dataConIsInfix data_con,
+ ifConWrapper = isJust (dataConWrapId_maybe data_con),
+ ifConExTCvs = map toIfaceBndr ex_tvs',
+ ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',
+ ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
+ ifConCtxt = tidyToIfaceContext con_env2 theta,
+ ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
+ ifConFields = dataConFieldLabels data_con,
+ ifConStricts = map (toIfaceBang con_env2)
+ (dataConImplBangs data_con),
+ ifConSrcStricts = map toIfaceSrcBang
+ (dataConSrcBangs data_con)}
+ where
+ (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
+ = dataConFullSig data_con
+ user_bndrs = dataConUserTyVarBinders data_con
+
+ -- Tidy the univ_tvs of the data constructor to be identical
+ -- to the tyConTyVars of the type constructor. This means
+ -- (a) we don't need to redundantly put them into the interface file
+ -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
+ -- we know that the type variables will line up
+ -- The latter (b) is important because we pretty-print type constructors
+ -- by converting to Iface syntax and pretty-printing that
+ con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
+ -- A bit grimy, perhaps, but it's simple!
+
+ (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs
+ user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs
+ to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
+
+ -- By this point, we have tidied every universal and existential
+ -- tyvar. Because of the dcUserTyCoVarBinders invariant
+ -- (see Note [DataCon user type variable binders]), *every*
+ -- user-written tyvar must be contained in the substitution that
+ -- tidying produced. Therefore, tidying the user-written tyvars is a
+ -- simple matter of looking up each variable in the substitution,
+ -- which tidyTyCoVarOcc accomplishes.
+ tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder
+ tidyUserTyCoVarBinder env (Bndr tv vis) =
+ Bndr (tidyTyCoVarOcc env tv) vis
+
+classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
+classToIfaceDecl env clas
+ = ( env1
+ , IfaceClass { ifName = getName tycon,
+ ifRoles = tyConRoles (classTyCon clas),
+ ifBinders = toIfaceTyCoVarBinders tc_binders,
+ ifBody = body,
+ ifFDs = map toIfaceFD clas_fds })
+ where
+ (_, clas_fds, sc_theta, _, clas_ats, op_stuff)
+ = classExtraBigSig clas
+ tycon = classTyCon clas
+
+ body | isAbstractTyCon tycon = IfAbstractClass
+ | otherwise
+ = IfConcreteClass {
+ ifClassCtxt = tidyToIfaceContext env1 sc_theta,
+ ifATs = map toIfaceAT clas_ats,
+ ifSigs = map toIfaceClassOp op_stuff,
+ ifMinDef = fmap getOccFS (classMinimalDef clas)
+ }
+
+ (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
+
+ toIfaceAT :: ClassATItem -> IfaceAT
+ toIfaceAT (ATI tc def)
+ = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
+ where
+ (env2, if_decl) = tyConToIfaceDecl env1 tc
+
+ toIfaceClassOp (sel_id, def_meth)
+ = ASSERT( sel_tyvars == binderVars tc_binders )
+ IfaceClassOp (getName sel_id)
+ (tidyToIfaceType env1 op_ty)
+ (fmap toDmSpec def_meth)
+ where
+ -- Be careful when splitting the type, because of things
+ -- like class Foo a where
+ -- op :: (?x :: String) => a -> a
+ -- and class Baz a where
+ -- op :: (Ord a) => a -> a
+ (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
+ op_ty = funResultTy rho_ty
+
+ toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
+ toDmSpec (_, VanillaDM) = VanillaDM
+ toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
+
+ toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1
+ ,map (tidyTyVar env1) tvs2)
+
+--------------------------
+
+tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
+-- If the type variable "binder" is in scope, don't re-bind it
+-- In a class decl, for example, the ATD binders mention
+-- (amd must mention) the class tyvars
+tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
+ = case lookupVarEnv subst tv of
+ Just tv' -> (env, Bndr tv' vis)
+ Nothing -> tidyTyCoVarBinder env tvb
+
+tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
+tidyTyConBinders = mapAccumL tidyTyConBinder
+
+tidyTyVar :: TidyEnv -> TyVar -> FastString
+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
+
+--------------------------
+instanceToIfaceInst :: ClsInst -> IfaceClsInst
+instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
+ , is_cls_nm = cls_name, is_cls = cls
+ , is_tcs = mb_tcs
+ , is_orphan = orph })
+ = ASSERT( cls_name == className cls )
+ IfaceClsInst { ifDFun = dfun_name,
+ ifOFlag = oflag,
+ ifInstCls = cls_name,
+ ifInstTys = map do_rough mb_tcs,
+ ifInstOrph = orph }
+ where
+ do_rough Nothing = Nothing
+ do_rough (Just n) = Just (toIfaceTyCon_name n)
+
+ dfun_name = idName dfun_id
+
+
+--------------------------
+famInstToIfaceFamInst :: FamInst -> IfaceFamInst
+famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
+ fi_fam = fam,
+ fi_tcs = roughs })
+ = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
+ , ifFamInstFam = fam
+ , ifFamInstTys = map do_rough roughs
+ , ifFamInstOrph = orph }
+ where
+ do_rough Nothing = Nothing
+ do_rough (Just n) = Just (toIfaceTyCon_name n)
+
+ fam_decl = tyConName $ coAxiomTyCon axiom
+ mod = ASSERT( isExternalName (coAxiomName axiom) )
+ nameModule (coAxiomName axiom)
+ is_local name = nameIsLocalOrFrom mod name
+
+ lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
+
+ orph | is_local fam_decl
+ = NotOrphan (nameOccName fam_decl)
+ | otherwise
+ = chooseOrphanAnchor lhs_names
+
+--------------------------
+coreRuleToIfaceRule :: CoreRule -> IfaceRule
+coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
+ = pprTrace "toHsRule: builtin" (ppr fn) $
+ bogusIfaceRule fn
+
+coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
+ ru_act = act, ru_bndrs = bndrs,
+ ru_args = args, ru_rhs = rhs,
+ ru_orphan = orph, ru_auto = auto })
+ = IfaceRule { ifRuleName = name, ifActivation = act,
+ ifRuleBndrs = map toIfaceBndr bndrs,
+ ifRuleHead = fn,
+ ifRuleArgs = map do_arg args,
+ ifRuleRhs = toIfaceExpr rhs,
+ ifRuleAuto = auto,
+ ifRuleOrph = orph }
+ where
+ -- For type args we must remove synonyms from the outermost
+ -- level. Reason: so that when we read it back in we'll
+ -- construct the same ru_rough field as we have right now;
+ -- see tcIfaceRule
+ do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
+ do_arg (Coercion co) = IfaceCo (toIfaceCoercion co)
+ do_arg arg = toIfaceExpr arg
+
+bogusIfaceRule :: Name -> IfaceRule
+bogusIfaceRule id_name
+ = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
+ ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
+ ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
+ ifRuleAuto = True }
diff --git a/compiler/GHC/Iface/Utils.hs b/compiler/GHC/Iface/Recomp.hs
index 663a963688..6028a94204 100644
--- a/compiler/GHC/Iface/Utils.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -1,62 +1,14 @@
-{-
-(c) The University of Glasgow 2006-2008
-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--}
-
-{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
--- | Module for constructing @ModIface@ values (interface files),
--- writing them to disk and comparing two versions to see if
--- recompilation is required.
-module GHC.Iface.Utils (
- mkPartialIface,
- mkFullIface,
-
- mkIfaceTc,
-
- writeIfaceFile, -- Write the interface file
-
- checkOldIface, -- See if recompilation is required, by
- -- comparing version information
- RecompileRequired(..), recompileRequired,
- mkIfaceExports,
-
- coAxiomToIfaceDecl,
- tyThingToIfaceDecl -- Converting things to their Iface equivalents
- ) where
-
-{-
- -----------------------------------------------
- Recompilation checking
- -----------------------------------------------
-
-A complete description of how recompilation checking works can be
-found in the wiki commentary:
-
- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance
-
-Please read the above page for a top-down description of how this all
-works. Notes below cover specific issues related to the implementation.
-
-Basic idea:
-
- * In the mi_usages information in an interface, we record the
- fingerprint of each free variable of the module
-
- * In mkIface, we compute the fingerprint of each exported thing A.f.
- For each external thing that A.f refers to, we include the fingerprint
- of the external reference when computing the fingerprint of A.f. So
- if anything that A.f depends on changes, then A.f's fingerprint will
- change.
- Also record any dependent files added with
- * addDependentFile
- * #include
- * -optP-include
-
- * In checkOldIface we compare the mi_usages for the module with
- the actual fingerprint for all each thing recorded in mi_usages
--}
+-- | Module for detecting if recompilation is required
+module GHC.Iface.Recomp
+ ( checkOldIface
+ , RecompileRequired(..)
+ , recompileRequired
+ , addFingerprints
+ )
+where
#include "HsVersions.h"
@@ -65,335 +17,674 @@ import GhcPrelude
import GHC.Iface.Syntax
import BinFingerprint
import GHC.Iface.Load
-import GHC.CoreToIface
import FlagChecker
-import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )
-import Id
import Annotations
import GHC.Core
-import Class
-import TyCon
-import CoAxiom
-import ConLike
-import DataCon
-import Type
-import TcType
-import InstEnv
-import FamInstEnv
import TcRnMonad
import GHC.Hs
import GHC.Driver.Types
import GHC.Driver.Finder
import GHC.Driver.Session
-import VarEnv
-import Var
import Name
-import Avail
-import RdrName
-import NameEnv
import NameSet
import Module
-import GHC.Iface.Binary
import ErrUtils
import Digraph
import SrcLoc
import Outputable
-import BasicTypes hiding ( SuccessFlag(..) )
import Unique
import Util hiding ( eqListBy )
-import FastString
import Maybes
import Binary
import Fingerprint
import Exception
import UniqSet
import GHC.Driver.Packages
-import GHC.HsToCore.Docs
import Control.Monad
import Data.Function
-import Data.List (find, findIndex, mapAccumL, sortBy, sort)
+import Data.List (find, sortBy, sort)
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Data.Ord
-import Data.IORef
-import System.Directory
-import System.FilePath
-import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),
- pluginRecompile', plugins )
+import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )
--Qualified import so we can define a Semigroup instance
-- but it doesn't clash with Outputable.<>
import qualified Data.Semigroup
{-
-************************************************************************
-* *
-\subsection{Completing an interface}
-* *
-************************************************************************
+ -----------------------------------------------
+ Recompilation checking
+ -----------------------------------------------
+
+A complete description of how recompilation checking works can be
+found in the wiki commentary:
+
+ https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance
+
+Please read the above page for a top-down description of how this all
+works. Notes below cover specific issues related to the implementation.
+
+Basic idea:
+
+ * In the mi_usages information in an interface, we record the
+ fingerprint of each free variable of the module
+
+ * In mkIface, we compute the fingerprint of each exported thing A.f.
+ For each external thing that A.f refers to, we include the fingerprint
+ of the external reference when computing the fingerprint of A.f. So
+ if anything that A.f depends on changes, then A.f's fingerprint will
+ change.
+ Also record any dependent files added with
+ * addDependentFile
+ * #include
+ * -optP-include
+
+ * In checkOldIface we compare the mi_usages for the module with
+ the actual fingerprint for all each thing recorded in mi_usages
-}
-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 -> Maybe NameSet -> IO ModIface
-mkFullIface hsc_env partial_iface mb_non_cafs = do
- let decls
- | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
- = mi_decls partial_iface
- | otherwise
- = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs
+data RecompileRequired
+ = UpToDate
+ -- ^ everything is up to date, recompilation is not required
+ | MustCompile
+ -- ^ The .hs file has been touched, or the .o/.hi file does not exist
+ | RecompBecause String
+ -- ^ The .o/.hi files are up to date, but something else has changed
+ -- to force recompilation; the String says what (one-line summary)
+ deriving Eq
+
+instance Semigroup RecompileRequired where
+ UpToDate <> r = r
+ mc <> _ = mc
- full_iface <-
- {-# SCC "addFingerprints" #-}
- addFingerprints hsc_env partial_iface{ mi_decls = decls }
+instance Monoid RecompileRequired where
+ mempty = UpToDate
- -- Debug printing
- dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)
+recompileRequired :: RecompileRequired -> Bool
+recompileRequired UpToDate = False
+recompileRequired _ = True
- return full_iface
+-- | Top level function to check if the version of an old interface file
+-- is equivalent to the current source file the user asked us to compile.
+-- If the same, we can avoid recompilation. We return a tuple where the
+-- first element is a bool saying if we should recompile the object file
+-- and the second is maybe the interface file, where Nothing means to
+-- rebuild the interface file and not use the existing one.
+checkOldIface
+ :: HscEnv
+ -> ModSummary
+ -> SourceModified
+ -> Maybe ModIface -- Old interface from compilation manager, if any
+ -> IO (RecompileRequired, Maybe ModIface)
-updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl]
-updateDeclCafInfos decls Nothing = decls
-updateDeclCafInfos decls (Just non_cafs) = map update_decl decls
+checkOldIface hsc_env mod_summary source_modified maybe_iface
+ = do let dflags = hsc_dflags hsc_env
+ showPass dflags $
+ "Checking old interface for " ++
+ (showPpr dflags $ ms_mod mod_summary) ++
+ " (use -ddump-hi-diffs for more details)"
+ initIfaceCheck (text "checkOldIface") hsc_env $
+ check_old_iface hsc_env mod_summary source_modified maybe_iface
+
+check_old_iface
+ :: HscEnv
+ -> ModSummary
+ -> SourceModified
+ -> Maybe ModIface
+ -> IfG (RecompileRequired, Maybe ModIface)
+
+check_old_iface hsc_env mod_summary src_modified maybe_iface
+ = let dflags = hsc_dflags hsc_env
+ getIface =
+ case maybe_iface of
+ Just _ -> do
+ traceIf (text "We already have the old interface for" <+>
+ ppr (ms_mod mod_summary))
+ return maybe_iface
+ Nothing -> loadIface
+
+ loadIface = do
+ let iface_path = msHiFilePath mod_summary
+ read_result <- readIface (ms_mod mod_summary) iface_path
+ case read_result of
+ Failed err -> do
+ traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
+ traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)
+ return Nothing
+ Succeeded iface -> do
+ traceIf (text "Read the interface file" <+> text iface_path)
+ return $ Just iface
+
+ src_changed
+ | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
+ | SourceModified <- src_modified = True
+ | otherwise = False
+ in do
+ when src_changed $
+ traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
+
+ case src_changed of
+ -- If the source has changed and we're in interactive mode,
+ -- avoid reading an interface; just return the one we might
+ -- have been supplied with.
+ True | not (isObjectTarget $ hscTarget dflags) ->
+ return (MustCompile, maybe_iface)
+
+ -- Try and read the old interface for the current module
+ -- from the .hi file left from the last time we compiled it
+ True -> do
+ maybe_iface' <- getIface
+ return (MustCompile, maybe_iface')
+
+ False -> do
+ maybe_iface' <- getIface
+ case maybe_iface' of
+ -- We can't retrieve the iface
+ Nothing -> return (MustCompile, Nothing)
+
+ -- We have got the old iface; check its versions
+ -- even in the SourceUnmodifiedAndStable case we
+ -- should check versions because some packages
+ -- might have changed or gone away.
+ Just iface -> checkVersions hsc_env mod_summary iface
+
+-- | Check if a module is still the same 'version'.
+--
+-- This function is called in the recompilation checker after we have
+-- determined that the module M being checked hasn't had any changes
+-- to its source file since we last compiled M. So at this point in general
+-- two things may have changed that mean we should recompile M:
+-- * The interface export by a dependency of M has changed.
+-- * The compiler flags specified this time for M have changed
+-- in a manner that is significant for recompilation.
+-- We return not just if we should recompile the object file but also
+-- if we should rebuild the interface file.
+checkVersions :: HscEnv
+ -> ModSummary
+ -> ModIface -- Old interface
+ -> IfG (RecompileRequired, Maybe ModIface)
+checkVersions hsc_env mod_summary iface
+ = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
+ ppr (mi_module iface) <> colon)
+
+ -- readIface will have verified that the InstalledUnitId matches,
+ -- but we ALSO must make sure the instantiation matches up. See
+ -- test case bkpcabal04!
+ ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)
+ then return (RecompBecause "-this-unit-id changed", Nothing) else do {
+ ; recomp <- checkFlagHash hsc_env iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkOptimHash hsc_env iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkHpcHash hsc_env iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkMergedSignatures mod_summary iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkHsig mod_summary iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkHie mod_summary
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkDependencies hsc_env mod_summary iface
+ ; if recompileRequired recomp then return (recomp, Just iface) else do {
+ ; recomp <- checkPlugins hsc_env iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+
+
+ -- Source code unchanged and no errors yet... carry on
+ --
+ -- First put the dependent-module info, read from the old
+ -- interface, into the envt, so that when we look for
+ -- interfaces we look for the right one (.hi or .hi-boot)
+ --
+ -- It's just temporary because either the usage check will succeed
+ -- (in which case we are done with this module) or it'll fail (in which
+ -- case we'll compile the module from scratch anyhow).
+ --
+ -- We do this regardless of compilation mode, although in --make mode
+ -- all the dependent modules should be in the HPT already, so it's
+ -- quite redundant
+ ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
+ ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
+ ; return (recomp, Just iface)
+ }}}}}}}}}}
where
- update_decl decl
- | IfaceId nm ty details infos <- decl
- , elemNameSet nm non_cafs
- = IfaceId nm ty details (HsNoCafRefs : infos)
- | otherwise
- = decl
-
--- | 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
- -> SafeHaskellMode -- The safe haskell mode
- -> ModDetails -- gotten from mkBootModDetails, probably
- -> TcGblEnv -- Usages, deprecations, etc
- -> IO ModIface
-mkIfaceTc hsc_env safe_mode mod_details
- tc_result@TcGblEnv{ tcg_mod = this_mod,
- tcg_src = hsc_src,
- tcg_imports = imports,
- tcg_rdr_env = rdr_env,
- tcg_fix_env = fix_env,
- tcg_merged = merged,
- tcg_warns = warns,
- tcg_hpc = other_hpc_info,
- tcg_th_splice_used = tc_splice_used,
- tcg_dependent_files = dependent_files
- }
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+ -- This is a bit of a hack really
+ mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
+ mod_deps = mkModDeps (dep_mods (mi_deps iface))
+
+-- | Check if any plugins are requesting recompilation
+checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
+checkPlugins hsc iface = liftIO $ do
+ new_fingerprint <- fingerprintPlugins hsc
+ 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
+
+fingerprintPlugins :: HscEnv -> IO Fingerprint
+fingerprintPlugins hsc_env = do
+ fingerprintPlugins' $ plugins (hsc_dflags hsc_env)
+
+fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
+fingerprintPlugins' plugins = do
+ res <- mconcat <$> mapM pluginRecompile' plugins
+ return $ case res of
+ NoForceRecompile -> fingerprintString "NoForceRecompile"
+ ForceRecompile -> fingerprintString "ForceRecompile"
+ -- is the chance of collision worth worrying about?
+ -- An alternative is to fingerprintFingerprints [fingerprintString
+ -- "maybeRecompile", fp]
+ (MaybeRecompile fp) -> fp
+
+
+pluginRecompileToRecompileRequired
+ :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
+pluginRecompileToRecompileRequired old_fp new_fp pr
+ | old_fp == new_fp =
+ case pr of
+ NoForceRecompile -> UpToDate
+
+ -- we already checked the fingerprint above so a mismatch is not possible
+ -- here, remember that: `fingerprint (MaybeRecomp x) == x`.
+ MaybeRecompile _ -> UpToDate
+
+ -- when we have an impure plugin in the stack we have to unconditionally
+ -- recompile since it might integrate all sorts of crazy IO results into
+ -- its compilation output.
+ ForceRecompile -> RecompBecause "Impure plugin forced recompilation"
+
+ | old_fp `elem` magic_fingerprints ||
+ new_fp `elem` magic_fingerprints
+ -- The fingerprints do not match either the old or new one is a magic
+ -- fingerprint. This happens when non-pure plugins are added for the first
+ -- time or when we go from one recompilation strategy to another: (force ->
+ -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)
+ --
+ -- For example when we go from from ForceRecomp to NoForceRecomp
+ -- recompilation is triggered since the old impure plugins could have
+ -- changed the build output which is now back to normal.
+ = RecompBecause "Plugins changed"
+
+ | otherwise =
+ let reason = "Plugin fingerprint changed" in
+ case pr of
+ -- even though a plugin is forcing recompilation the fingerprint changed
+ -- which would cause recompilation anyways so we report the fingerprint
+ -- change instead.
+ ForceRecompile -> RecompBecause reason
+
+ _ -> RecompBecause reason
+
+ where
+ magic_fingerprints =
+ [ fingerprintString "NoForceRecompile"
+ , fingerprintString "ForceRecompile"
+ ]
+
+
+-- | Check if an hsig file needs recompilation because its
+-- implementing module has changed.
+checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
+checkHsig mod_summary iface = do
+ dflags <- getDynFlags
+ let outer_mod = ms_mod mod_summary
+ inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
+ MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+ case inner_mod == mi_semantic_module iface of
+ True -> up_to_date (text "implementing module unchanged")
+ False -> return (RecompBecause "implementing module changed")
+
+-- | Check if @.hie@ file is out of date or missing.
+checkHie :: ModSummary -> IfG RecompileRequired
+checkHie mod_summary = do
+ dflags <- getDynFlags
+ let hie_date_opt = ms_hie_date mod_summary
+ hs_date = ms_hs_date mod_summary
+ pure $ case gopt Opt_WriteHie dflags of
+ False -> UpToDate
+ True -> case hie_date_opt of
+ Nothing -> RecompBecause "HIE file is missing"
+ Just hie_date
+ | hie_date < hs_date
+ -> RecompBecause "HIE file is out of date"
+ | otherwise
+ -> UpToDate
+
+-- | Check the flags haven't changed
+checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkFlagHash hsc_env iface = do
+ let old_hash = mi_flag_hash (mi_final_exts iface)
+ new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
+ (mi_module iface)
+ putNameLiterally
+ case old_hash == new_hash of
+ True -> up_to_date (text "Module flags unchanged")
+ False -> out_of_date_hash "flags changed"
+ (text " Module flags have changed")
+ old_hash new_hash
+
+-- | Check the optimisation flags haven't changed
+checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkOptimHash hsc_env iface = do
+ let old_hash = mi_opt_hash (mi_final_exts iface)
+ new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)
+ putNameLiterally
+ if | old_hash == new_hash
+ -> up_to_date (text "Optimisation flags unchanged")
+ | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
+ -> up_to_date (text "Optimisation flags changed; ignoring")
+ | otherwise
+ -> out_of_date_hash "Optimisation flags changed"
+ (text " Optimisation flags have changed")
+ old_hash new_hash
+
+-- | Check the HPC flags haven't changed
+checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkHpcHash hsc_env iface = do
+ let old_hash = mi_hpc_hash (mi_final_exts iface)
+ new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)
+ putNameLiterally
+ if | old_hash == new_hash
+ -> up_to_date (text "HPC flags unchanged")
+ | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
+ -> up_to_date (text "HPC flags changed; ignoring")
+ | otherwise
+ -> out_of_date_hash "HPC flags changed"
+ (text " HPC flags have changed")
+ old_hash new_hash
+
+-- Check that the set of signatures we are merging in match.
+-- If the -unit-id flags change, this can change too.
+checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
+checkMergedSignatures mod_summary iface = do
+ dflags <- getDynFlags
+ let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
+ new_merged = case Map.lookup (ms_mod_name mod_summary)
+ (requirementContext (pkgState dflags)) of
+ Nothing -> []
+ Just r -> sort $ map (indefModuleToModule dflags) r
+ if old_merged == new_merged
+ then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)
+ else return (RecompBecause "signatures to merge in changed")
+
+-- If the direct imports of this module are resolved to targets that
+-- are not among the dependencies of the previous interface file,
+-- then we definitely need to recompile. This catches cases like
+-- - an exposed package has been upgraded
+-- - we are compiling with different package flags
+-- - a home module that was shadowing a package module has been removed
+-- - a new home module has been added that shadows a package module
+-- See bug #1372.
+--
+-- In addition, we also check if the union of dependencies of the imported
+-- modules has any difference to the previous set of dependencies. We would need
+-- to recompile in that case also since the `mi_deps` field of ModIface needs
+-- to be updated to match that information. This is one of the invariants
+-- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).
+-- See bug #16511.
+--
+-- Returns (RecompBecause <textual reason>) if recompilation is required.
+checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
+checkDependencies hsc_env summary iface
+ = do
+ checkList $
+ [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
+ , do
+ (recomp, mnames_seen) <- runUntilRecompRequired $ map
+ checkForNewHomeDependency
+ (ms_home_imps summary)
+ case recomp of
+ UpToDate -> do
+ let
+ seen_home_deps = Set.unions $ map Set.fromList mnames_seen
+ checkIfAllOldHomeDependenciesAreSeen seen_home_deps
+ _ -> return recomp]
+ where
+ prev_dep_mods = dep_mods (mi_deps iface)
+ prev_dep_plgn = dep_plgins (mi_deps iface)
+ prev_dep_pkgs = dep_pkgs (mi_deps iface)
+
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+
+ dep_missing (mb_pkg, L _ mod) = do
+ find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
+ let reason = moduleNameString mod ++ " changed"
+ case find_res of
+ Found _ mod
+ | pkg == this_pkg
+ -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn
+ then do traceHiDiffs $
+ text "imported module " <> quotes (ppr mod) <>
+ text " not among previous dependencies"
+ return (RecompBecause reason)
+ else
+ return UpToDate
+ | otherwise
+ -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)
+ then do traceHiDiffs $
+ text "imported module " <> quotes (ppr mod) <>
+ text " is from package " <> quotes (ppr pkg) <>
+ text ", which is not among previous dependencies"
+ return (RecompBecause reason)
+ else
+ return UpToDate
+ where pkg = moduleUnitId mod
+ _otherwise -> return (RecompBecause reason)
+
+ old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods
+ isOldHomeDeps = flip Set.member old_deps
+ checkForNewHomeDependency (L _ mname) = do
+ let
+ mod = mkModule this_pkg mname
+ str_mname = moduleNameString mname
+ reason = str_mname ++ " changed"
+ -- We only want to look at home modules to check if any new home dependency
+ -- pops in and thus here, skip modules that are not home. Checking
+ -- membership in old home dependencies suffice because the `dep_missing`
+ -- check already verified that all imported home modules are present there.
+ if not (isOldHomeDeps mname)
+ then return (UpToDate, [])
+ else do
+ mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do
+ let mnames = mname:(map fst $ filter (not . snd) $
+ dep_mods $ mi_deps imported_iface)
+ case find (not . isOldHomeDeps) mnames of
+ Nothing -> return (UpToDate, mnames)
+ Just new_dep_mname -> do
+ traceHiDiffs $
+ text "imported home module " <> quotes (ppr mod) <>
+ text " has a new dependency " <> quotes (ppr new_dep_mname)
+ return (RecompBecause reason, [])
+ return $ fromMaybe (MustCompile, []) mb_result
+
+ -- Performs all recompilation checks in the list until a check that yields
+ -- recompile required is encountered. Returns the list of the results of
+ -- all UpToDate checks.
+ runUntilRecompRequired [] = return (UpToDate, [])
+ runUntilRecompRequired (check:checks) = do
+ (recompile, value) <- check
+ if recompileRequired recompile
+ then return (recompile, [])
+ else do
+ (recomp, values) <- runUntilRecompRequired checks
+ return (recomp, value:values)
+
+ checkIfAllOldHomeDependenciesAreSeen seen_deps = do
+ let unseen_old_deps = Set.difference
+ old_deps
+ seen_deps
+ if not (null unseen_old_deps)
+ then do
+ let missing_dep = Set.elemAt 0 unseen_old_deps
+ traceHiDiffs $
+ text "missing old home dependency " <> quotes (ppr missing_dep)
+ return $ RecompBecause "missing old dependency"
+ else return UpToDate
+
+needInterface :: Module -> (ModIface -> IfG RecompileRequired)
+ -> IfG RecompileRequired
+needInterface mod continue
= do
- let used_names = mkUsedNames tc_result
- let pluginModules =
- map lpModule (cachedPlugins (hsc_dflags hsc_env))
- deps <- mkDependencies
- (thisInstalledUnitId (hsc_dflags hsc_env))
- (map mi_module pluginModules) tc_result
- let hpc_info = emptyHpcInfo other_hpc_info
- used_th <- readIORef tc_splice_used
- dep_files <- (readIORef dependent_files)
- -- Do NOT use semantic module here; this_mod in mkUsageInfo
- -- is used solely to decide if we should record a dependency
- -- or not. When we instantiate a signature, the semantic
- -- module is something we want to record dependencies for,
- -- but if you pass that in here, we'll decide it's the local
- -- module and does not need to be recorded as a dependency.
- -- See Note [Identity versus semantic module]
- usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names
- dep_files merged pluginModules
-
- let (doc_hdr', doc_map, arg_map) = extractDocs tc_result
-
- let partial_iface = mkIface_ hsc_env
- this_mod hsc_src
- used_th deps rdr_env
- fix_env warns hpc_info
- (imp_trust_own_pkg imports) safe_mode usages
- doc_hdr' doc_map arg_map
- mod_details
-
- mkFullIface hsc_env partial_iface Nothing
-
-mkIface_ :: HscEnv -> Module -> HscSource
- -> Bool -> Dependencies -> GlobalRdrEnv
- -> NameEnv FixItem -> Warnings -> HpcInfo
- -> Bool
- -> SafeHaskellMode
- -> [Usage]
- -> Maybe HsDocString
- -> DeclDocMap
- -> ArgDocMap
- -> ModDetails
- -> 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
- ModDetails{ md_insts = insts,
- md_fam_insts = fam_insts,
- md_rules = rules,
- md_anns = anns,
- md_types = type_env,
- md_exports = exports,
- md_complete_sigs = complete_sigs }
--- NB: notice that mkIface does not look at the bindings
--- only at the TypeEnv. The previous Tidy phase has
--- put exactly the info into the TypeEnv that we want
--- to expose in the interface
+ mb_recomp <- getFromModIface
+ "need version info for"
+ mod
+ continue
+ case mb_recomp of
+ Nothing -> return MustCompile
+ Just recomp -> return recomp
+
+getFromModIface :: String -> Module -> (ModIface -> IfG a)
+ -> IfG (Maybe a)
+getFromModIface doc_msg mod getter
+ = do -- Load the imported interface if possible
+ let doc_str = sep [text doc_msg, ppr mod]
+ traceHiDiffs (text "Checking innterface for module" <+> ppr mod)
+ mb_iface <- loadInterface doc_str mod ImportBySystem
+ -- Load the interface, but don't complain on failure;
+ -- Instead, get an Either back which we can test
+
+ case mb_iface of
+ Failed _ -> do
+ traceHiDiffs (sep [text "Couldn't load interface for module",
+ ppr mod])
+ return Nothing
+ -- Couldn't find or parse a module mentioned in the
+ -- old interface file. Don't complain: it might
+ -- just be that the current module doesn't need that
+ -- import and it's been deleted
+ Succeeded iface -> Just <$> getter iface
+
+-- | Given the usage information extracted from the old
+-- M.hi file for the module being compiled, figure out
+-- whether M needs to be recompiled.
+checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
+checkModUsage _this_pkg UsagePackageModule{
+ usg_mod = mod,
+ usg_mod_hash = old_mod_hash }
+ = needInterface mod $ \iface -> do
+ let reason = moduleNameString (moduleName mod) ++ " changed"
+ 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
+ -- a dependent package has changed.
+
+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 (mi_final_exts iface))
+
+checkModUsage this_pkg UsageHomeModule{
+ usg_mod_name = mod_name,
+ usg_mod_hash = old_mod_hash,
+ usg_exports = maybe_old_export_hash,
+ usg_entities = old_decl_hash }
= do
- let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)
- entities = typeEnvElts type_env
- decls = [ tyThingToIfaceDecl entity
- | entity <- entities,
- let name = getName entity,
- not (isImplicitTyThing entity),
- -- No implicit Ids and class tycons in the interface file
- not (isWiredInName name),
- -- Nor wired-in things; the compiler knows about them anyhow
- nameIsLocalOrFrom semantic_mod name ]
- -- Sigh: see Note [Root-main Id] in TcRnDriver
- -- NB: ABSOLUTELY need to check against semantic_mod,
- -- because all of the names in an hsig p[H=<H>]:H
- -- are going to be for <H>, not the former id!
- -- See Note [Identity versus semantic module]
-
- fixities = sortBy (comparing fst)
- [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
- -- The order of fixities returned from nameEnvElts is not
- -- deterministic, so we sort by OccName to canonicalize it.
- -- See Note [Deterministic UniqFM] in UniqDFM for more details.
- warns = src_warns
- iface_rules = map coreRuleToIfaceRule rules
- iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
- iface_fam_insts = map famInstToIfaceFamInst fam_insts
- trust_info = setSafeMode safe_mode
- annotations = map mkIfaceAnnotation anns
- icomplete_sigs = map mkIfaceCompleteSig complete_sigs
-
- 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,
- -- because the latter is not stable across compilations:
- cmp_inst = comparing (nameOccName . ifDFun)
- cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
-
- dflags = hsc_dflags hsc_env
-
- -- We only fill in mi_globals if the module was compiled to byte
- -- code. Otherwise, the compiler may not have retained all the
- -- top-level bindings and they won't be in the TypeEnv (see
- -- Desugar.addExportFlagsAndRules). The mi_globals field is used
- -- by GHCi to decide whether the module has its full top-level
- -- scope available. (#5534)
- maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
- maybeGlobalRdrEnv rdr_env
- | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
- | otherwise = Nothing
-
- ifFamInstTcName = ifFamInstFam
-
------------------------------
-writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
-writeIfaceFile dflags hi_file_path new_iface
- = do createDirectoryIfMissing True (takeDirectory hi_file_path)
- writeBinIface dflags hi_file_path new_iface
+ let mod = mkModule this_pkg mod_name
+ needInterface mod $ \iface -> do
+ let
+ 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)
--- -----------------------------------------------------------------------------
--- Look up parents and versions of Names
+ reason = moduleNameString mod_name ++ " changed"
--- This is like a global version of the mi_hash_fn field in each ModIface.
--- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
--- the parent and version info.
+ -- CHECK MODULE
+ recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
+ if not (recompileRequired recompile)
+ then return UpToDate
+ else do
+
+ -- CHECK EXPORT LIST
+ checkMaybeHash reason maybe_old_export_hash new_export_hash
+ (text " Export list changed") $ do
+
+ -- CHECK ITEMS ONE BY ONE
+ recompile <- checkList [ checkEntityUsage reason new_decl_hash u
+ | u <- old_decl_hash]
+ if recompileRequired recompile
+ then return recompile -- This one failed, so just bail out now
+ else up_to_date (text " Great! The bits I use are up to date")
+
+
+checkModUsage _this_pkg UsageFile{ usg_file_path = file,
+ usg_file_hash = old_hash } =
+ liftIO $
+ handleIO handle $ do
+ new_hash <- getFileHash file
+ if (old_hash /= new_hash)
+ then return recomp
+ else return UpToDate
+ where
+ recomp = RecompBecause (file ++ " changed")
+ handle =
+#if defined(DEBUG)
+ \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
+#else
+ \_ -> return recomp -- if we can't find the file, just recompile, don't fail
+#endif
+
+------------------------
+checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
+ -> IfG RecompileRequired
+checkModuleFingerprint reason old_mod_hash new_mod_hash
+ | new_mod_hash == old_mod_hash
+ = up_to_date (text "Module fingerprint unchanged")
-mkHashFun
- :: HscEnv -- needed to look up versions
- -> ExternalPackageState -- ditto
- -> (Name -> IO Fingerprint)
-mkHashFun hsc_env eps name
- | isHoleModule orig_mod
- = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))
| otherwise
- = lookup orig_mod
- where
- dflags = hsc_dflags hsc_env
- hpt = hsc_HPT hsc_env
- pit = eps_PIT eps
- occ = nameOccName name
- orig_mod = nameModule name
- lookup mod = do
- MASSERT2( isExternalName name, ppr name )
- iface <- case lookupIfaceByModule hpt pit mod of
- Just iface -> return iface
- Nothing -> do
- -- This can occur when we're writing out ifaces for
- -- requirements; we didn't do any /real/ typechecking
- -- so there's no guarantee everything is loaded.
- -- Kind of a heinous hack.
- iface <- initIfaceLoad hsc_env . withException
- $ loadInterface (text "lookupVers2") mod ImportBySystem
- return iface
- return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`
- pprPanic "lookupVers1" (ppr mod <+> ppr occ))
+ = out_of_date_hash reason (text " Module fingerprint has changed")
+ old_mod_hash new_mod_hash
+
+------------------------
+checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
+ -> IfG RecompileRequired -> IfG RecompileRequired
+checkMaybeHash reason maybe_old_hash new_hash doc continue
+ | Just hash <- maybe_old_hash, hash /= new_hash
+ = out_of_date_hash reason doc hash new_hash
+ | otherwise
+ = continue
+
+------------------------
+checkEntityUsage :: String
+ -> (OccName -> Maybe (OccName, Fingerprint))
+ -> (OccName, Fingerprint)
+ -> IfG RecompileRequired
+checkEntityUsage reason new_hash (name,old_hash)
+ = case new_hash name of
+
+ Nothing -> -- We used it before, but it ain't there now
+ out_of_date reason (sep [text "No longer exported:", ppr name])
+
+ Just (_, new_hash) -- It's there, but is it up to date?
+ | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
+ return UpToDate
+ | otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name)
+ old_hash new_hash
+
+up_to_date :: SDoc -> IfG RecompileRequired
+up_to_date msg = traceHiDiffs msg >> return UpToDate
+
+out_of_date :: String -> SDoc -> IfG RecompileRequired
+out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
+
+out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
+out_of_date_hash reason msg old_hash new_hash
+ = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
+
+----------------------
+checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
+-- This helper is used in two places
+checkList [] = return UpToDate
+checkList (check:checks) = do recompile <- check
+ if recompileRequired recompile
+ then return recompile
+ else checkList checks
+
-- ---------------------------------------------------------------------------
-- Compute fingerprints for the interface
@@ -788,20 +1079,6 @@ sortDependencies d
dep_finsts = sortBy stableModuleCmp (dep_finsts d),
dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }
--- | Creates cached lookup for the 'mi_anns' field of ModIface
--- Hackily, we use "module" as the OccName for any module-level annotations
-mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
-mkIfaceAnnCache anns
- = \n -> lookupOccEnv env n `orElse` []
- where
- pair (IfaceAnnotation target value) =
- (case target of
- NamedTarget occn -> occn
- ModuleTarget _ -> mkVarOcc "module"
- , [value])
- -- flipping (++), so the first argument is always short
- env = mkOccEnv_C (flip (++)) (map pair anns)
-
{-
************************************************************************
* *
@@ -810,7 +1087,7 @@ mkIfaceAnnCache anns
************************************************************************
Note [The ABI of an IfaceDecl]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The ABI of a declaration consists of:
(a) the full name of the identifier (inc. module and package,
@@ -1056,1040 +1333,54 @@ mkOrphMap get_key decls
= (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
| otherwise = (non_orphs, d:orphs)
-{-
-************************************************************************
-* *
- COMPLETE Pragmas
-* *
-************************************************************************
--}
-
-mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
-mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
-
-
-{-
-************************************************************************
-* *
- Keeping track of what we've slurped, and fingerprints
-* *
-************************************************************************
--}
-
-
-mkIfaceAnnotation :: Annotation -> IfaceAnnotation
-mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })
- = IfaceAnnotation {
- ifAnnotatedTarget = fmap nameOccName target,
- ifAnnotatedValue = payload
- }
-
-mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical
-mkIfaceExports exports
- = sortBy stableAvailCmp (map sort_subs exports)
- where
- sort_subs :: AvailInfo -> AvailInfo
- sort_subs (Avail n) = Avail n
- sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
- sort_subs (AvailTC n (m:ms) fs)
- | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
- | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
- -- Maintain the AvailTC Invariant
-
- sort_flds = sortBy (stableNameCmp `on` flSelector)
-
-{-
-Note [Original module]
-~~~~~~~~~~~~~~~~~~~~~
-Consider this:
- module X where { data family T }
- module Y( T(..) ) where { import X; data instance T Int = MkT Int }
-The exported Avail from Y will look like
- X.T{X.T, Y.MkT}
-That is, in Y,
- - only MkT is brought into scope by the data instance;
- - but the parent (used for grouping and naming in T(..) exports) is X.T
- - and in this case we export X.T too
-
-In the result of mkIfaceExports, the names are grouped by defining module,
-so we may need to split up a single Avail into multiple ones.
-
-Note [Internal used_names]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Most of the used_names are External Names, but we can have Internal
-Names too: see Note [Binders in Template Haskell] in Convert, and
-#5362 for an example. Such Names are always
- - Such Names are always for locally-defined things, for which we
- don't gather usage info, so we can just ignore them in ent_map
- - They are always System Names, hence the assert, just as a double check.
-
-
-************************************************************************
-* *
- Load the old interface file for this module (unless
- we have it already), and check whether it is up to date
-* *
-************************************************************************
--}
-
-data RecompileRequired
- = UpToDate
- -- ^ everything is up to date, recompilation is not required
- | MustCompile
- -- ^ The .hs file has been touched, or the .o/.hi file does not exist
- | RecompBecause String
- -- ^ The .o/.hi files are up to date, but something else has changed
- -- to force recompilation; the String says what (one-line summary)
- deriving Eq
-
-instance Semigroup RecompileRequired where
- UpToDate <> r = r
- mc <> _ = mc
-
-instance Monoid RecompileRequired where
- mempty = UpToDate
-
-recompileRequired :: RecompileRequired -> Bool
-recompileRequired UpToDate = False
-recompileRequired _ = True
-
-
-
--- | Top level function to check if the version of an old interface file
--- is equivalent to the current source file the user asked us to compile.
--- If the same, we can avoid recompilation. We return a tuple where the
--- first element is a bool saying if we should recompile the object file
--- and the second is maybe the interface file, where Nothing means to
--- rebuild the interface file and not use the existing one.
-checkOldIface
- :: HscEnv
- -> ModSummary
- -> SourceModified
- -> Maybe ModIface -- Old interface from compilation manager, if any
- -> IO (RecompileRequired, Maybe ModIface)
-
-checkOldIface hsc_env mod_summary source_modified maybe_iface
- = do let dflags = hsc_dflags hsc_env
- showPass dflags $
- "Checking old interface for " ++
- (showPpr dflags $ ms_mod mod_summary) ++
- " (use -ddump-hi-diffs for more details)"
- initIfaceCheck (text "checkOldIface") hsc_env $
- check_old_iface hsc_env mod_summary source_modified maybe_iface
-
-check_old_iface
- :: HscEnv
- -> ModSummary
- -> SourceModified
- -> Maybe ModIface
- -> IfG (RecompileRequired, Maybe ModIface)
-
-check_old_iface hsc_env mod_summary src_modified maybe_iface
- = let dflags = hsc_dflags hsc_env
- getIface =
- case maybe_iface of
- Just _ -> do
- traceIf (text "We already have the old interface for" <+>
- ppr (ms_mod mod_summary))
- return maybe_iface
- Nothing -> loadIface
-
- loadIface = do
- let iface_path = msHiFilePath mod_summary
- read_result <- readIface (ms_mod mod_summary) iface_path
- case read_result of
- Failed err -> do
- traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
- traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)
- return Nothing
- Succeeded iface -> do
- traceIf (text "Read the interface file" <+> text iface_path)
- return $ Just iface
-
- src_changed
- | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
- | SourceModified <- src_modified = True
- | otherwise = False
- in do
- when src_changed $
- traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
-
- case src_changed of
- -- If the source has changed and we're in interactive mode,
- -- avoid reading an interface; just return the one we might
- -- have been supplied with.
- True | not (isObjectTarget $ hscTarget dflags) ->
- return (MustCompile, maybe_iface)
-
- -- Try and read the old interface for the current module
- -- from the .hi file left from the last time we compiled it
- True -> do
- maybe_iface' <- getIface
- return (MustCompile, maybe_iface')
-
- False -> do
- maybe_iface' <- getIface
- case maybe_iface' of
- -- We can't retrieve the iface
- Nothing -> return (MustCompile, Nothing)
-
- -- We have got the old iface; check its versions
- -- even in the SourceUnmodifiedAndStable case we
- -- should check versions because some packages
- -- might have changed or gone away.
- Just iface -> checkVersions hsc_env mod_summary iface
-
--- | Check if a module is still the same 'version'.
---
--- This function is called in the recompilation checker after we have
--- determined that the module M being checked hasn't had any changes
--- to its source file since we last compiled M. So at this point in general
--- two things may have changed that mean we should recompile M:
--- * The interface export by a dependency of M has changed.
--- * The compiler flags specified this time for M have changed
--- in a manner that is significant for recompilation.
--- We return not just if we should recompile the object file but also
--- if we should rebuild the interface file.
-checkVersions :: HscEnv
- -> ModSummary
- -> ModIface -- Old interface
- -> IfG (RecompileRequired, Maybe ModIface)
-checkVersions hsc_env mod_summary iface
- = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
- ppr (mi_module iface) <> colon)
-
- -- readIface will have verified that the InstalledUnitId matches,
- -- but we ALSO must make sure the instantiation matches up. See
- -- test case bkpcabal04!
- ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)
- then return (RecompBecause "-this-unit-id changed", Nothing) else do {
- ; recomp <- checkFlagHash hsc_env iface
- ; if recompileRequired recomp then return (recomp, Nothing) else do {
- ; recomp <- checkOptimHash hsc_env iface
- ; if recompileRequired recomp then return (recomp, Nothing) else do {
- ; recomp <- checkHpcHash hsc_env iface
- ; if recompileRequired recomp then return (recomp, Nothing) else do {
- ; recomp <- checkMergedSignatures mod_summary iface
- ; if recompileRequired recomp then return (recomp, Nothing) else do {
- ; recomp <- checkHsig mod_summary iface
- ; if recompileRequired recomp then return (recomp, Nothing) else do {
- ; recomp <- checkHie mod_summary
- ; if recompileRequired recomp then return (recomp, Nothing) else do {
- ; recomp <- checkDependencies hsc_env mod_summary iface
- ; if recompileRequired recomp then return (recomp, Just iface) else do {
- ; recomp <- checkPlugins hsc_env iface
- ; if recompileRequired recomp then return (recomp, Nothing) else do {
-
-
- -- Source code unchanged and no errors yet... carry on
- --
- -- First put the dependent-module info, read from the old
- -- interface, into the envt, so that when we look for
- -- interfaces we look for the right one (.hi or .hi-boot)
- --
- -- It's just temporary because either the usage check will succeed
- -- (in which case we are done with this module) or it'll fail (in which
- -- case we'll compile the module from scratch anyhow).
- --
- -- We do this regardless of compilation mode, although in --make mode
- -- all the dependent modules should be in the HPT already, so it's
- -- quite redundant
- ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
- ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
- ; return (recomp, Just iface)
- }}}}}}}}}}
- where
- this_pkg = thisPackage (hsc_dflags hsc_env)
- -- This is a bit of a hack really
- mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
- mod_deps = mkModDeps (dep_mods (mi_deps iface))
-
--- | Check if any plugins are requesting recompilation
-checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
-checkPlugins hsc iface = liftIO $ do
- new_fingerprint <- fingerprintPlugins hsc
- 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
-
-fingerprintPlugins :: HscEnv -> IO Fingerprint
-fingerprintPlugins hsc_env = do
- fingerprintPlugins' $ plugins (hsc_dflags hsc_env)
-
-fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
-fingerprintPlugins' plugins = do
- res <- mconcat <$> mapM pluginRecompile' plugins
- return $ case res of
- NoForceRecompile -> fingerprintString "NoForceRecompile"
- ForceRecompile -> fingerprintString "ForceRecompile"
- -- is the chance of collision worth worrying about?
- -- An alternative is to fingerprintFingerprints [fingerprintString
- -- "maybeRecompile", fp]
- (MaybeRecompile fp) -> fp
-
-
-pluginRecompileToRecompileRequired
- :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
-pluginRecompileToRecompileRequired old_fp new_fp pr
- | old_fp == new_fp =
- case pr of
- NoForceRecompile -> UpToDate
-
- -- we already checked the fingerprint above so a mismatch is not possible
- -- here, remember that: `fingerprint (MaybeRecomp x) == x`.
- MaybeRecompile _ -> UpToDate
-
- -- when we have an impure plugin in the stack we have to unconditionally
- -- recompile since it might integrate all sorts of crazy IO results into
- -- its compilation output.
- ForceRecompile -> RecompBecause "Impure plugin forced recompilation"
-
- | old_fp `elem` magic_fingerprints ||
- new_fp `elem` magic_fingerprints
- -- The fingerprints do not match either the old or new one is a magic
- -- fingerprint. This happens when non-pure plugins are added for the first
- -- time or when we go from one recompilation strategy to another: (force ->
- -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)
- --
- -- For example when we go from from ForceRecomp to NoForceRecomp
- -- recompilation is triggered since the old impure plugins could have
- -- changed the build output which is now back to normal.
- = RecompBecause "Plugins changed"
-
- | otherwise =
- let reason = "Plugin fingerprint changed" in
- case pr of
- -- even though a plugin is forcing recompilation the fingerprint changed
- -- which would cause recompilation anyways so we report the fingerprint
- -- change instead.
- ForceRecompile -> RecompBecause reason
-
- _ -> RecompBecause reason
-
- where
- magic_fingerprints =
- [ fingerprintString "NoForceRecompile"
- , fingerprintString "ForceRecompile"
- ]
-
-
--- | Check if an hsig file needs recompilation because its
--- implementing module has changed.
-checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
-checkHsig mod_summary iface = do
- dflags <- getDynFlags
- let outer_mod = ms_mod mod_summary
- inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
- MASSERT( moduleUnitId outer_mod == thisPackage dflags )
- case inner_mod == mi_semantic_module iface of
- True -> up_to_date (text "implementing module unchanged")
- False -> return (RecompBecause "implementing module changed")
-
--- | Check if @.hie@ file is out of date or missing.
-checkHie :: ModSummary -> IfG RecompileRequired
-checkHie mod_summary = do
- dflags <- getDynFlags
- let hie_date_opt = ms_hie_date mod_summary
- hs_date = ms_hs_date mod_summary
- pure $ case gopt Opt_WriteHie dflags of
- False -> UpToDate
- True -> case hie_date_opt of
- Nothing -> RecompBecause "HIE file is missing"
- Just hie_date
- | hie_date < hs_date
- -> RecompBecause "HIE file is out of date"
- | otherwise
- -> UpToDate
-
--- | Check the flags haven't changed
-checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
-checkFlagHash hsc_env iface = do
- let old_hash = mi_flag_hash (mi_final_exts iface)
- new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
- (mi_module iface)
- putNameLiterally
- case old_hash == new_hash of
- True -> up_to_date (text "Module flags unchanged")
- False -> out_of_date_hash "flags changed"
- (text " Module flags have changed")
- old_hash new_hash
-
--- | Check the optimisation flags haven't changed
-checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
-checkOptimHash hsc_env iface = do
- let old_hash = mi_opt_hash (mi_final_exts iface)
- new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)
- putNameLiterally
- if | old_hash == new_hash
- -> up_to_date (text "Optimisation flags unchanged")
- | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
- -> up_to_date (text "Optimisation flags changed; ignoring")
- | otherwise
- -> out_of_date_hash "Optimisation flags changed"
- (text " Optimisation flags have changed")
- old_hash new_hash
-
--- | Check the HPC flags haven't changed
-checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
-checkHpcHash hsc_env iface = do
- let old_hash = mi_hpc_hash (mi_final_exts iface)
- new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)
- putNameLiterally
- if | old_hash == new_hash
- -> up_to_date (text "HPC flags unchanged")
- | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
- -> up_to_date (text "HPC flags changed; ignoring")
- | otherwise
- -> out_of_date_hash "HPC flags changed"
- (text " HPC flags have changed")
- old_hash new_hash
-
--- Check that the set of signatures we are merging in match.
--- If the -unit-id flags change, this can change too.
-checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
-checkMergedSignatures mod_summary iface = do
- dflags <- getDynFlags
- let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
- new_merged = case Map.lookup (ms_mod_name mod_summary)
- (requirementContext (pkgState dflags)) of
- Nothing -> []
- Just r -> sort $ map (indefModuleToModule dflags) r
- if old_merged == new_merged
- then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)
- else return (RecompBecause "signatures to merge in changed")
-
--- If the direct imports of this module are resolved to targets that
--- are not among the dependencies of the previous interface file,
--- then we definitely need to recompile. This catches cases like
--- - an exposed package has been upgraded
--- - we are compiling with different package flags
--- - a home module that was shadowing a package module has been removed
--- - a new home module has been added that shadows a package module
--- See bug #1372.
---
--- In addition, we also check if the union of dependencies of the imported
--- modules has any difference to the previous set of dependencies. We would need
--- to recompile in that case also since the `mi_deps` field of ModIface needs
--- to be updated to match that information. This is one of the invariants
--- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).
--- See bug #16511.
---
--- Returns (RecompBecause <textual reason>) if recompilation is required.
-checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
-checkDependencies hsc_env summary iface
- = do
- checkList $
- [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
- , do
- (recomp, mnames_seen) <- runUntilRecompRequired $ map
- checkForNewHomeDependency
- (ms_home_imps summary)
- case recomp of
- UpToDate -> do
- let
- seen_home_deps = Set.unions $ map Set.fromList mnames_seen
- checkIfAllOldHomeDependenciesAreSeen seen_home_deps
- _ -> return recomp]
- where
- prev_dep_mods = dep_mods (mi_deps iface)
- prev_dep_plgn = dep_plgins (mi_deps iface)
- prev_dep_pkgs = dep_pkgs (mi_deps iface)
-
- this_pkg = thisPackage (hsc_dflags hsc_env)
-
- dep_missing (mb_pkg, L _ mod) = do
- find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
- let reason = moduleNameString mod ++ " changed"
- case find_res of
- Found _ mod
- | pkg == this_pkg
- -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn
- then do traceHiDiffs $
- text "imported module " <> quotes (ppr mod) <>
- text " not among previous dependencies"
- return (RecompBecause reason)
- else
- return UpToDate
- | otherwise
- -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)
- then do traceHiDiffs $
- text "imported module " <> quotes (ppr mod) <>
- text " is from package " <> quotes (ppr pkg) <>
- text ", which is not among previous dependencies"
- return (RecompBecause reason)
- else
- return UpToDate
- where pkg = moduleUnitId mod
- _otherwise -> return (RecompBecause reason)
-
- old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods
- isOldHomeDeps = flip Set.member old_deps
- checkForNewHomeDependency (L _ mname) = do
- let
- mod = mkModule this_pkg mname
- str_mname = moduleNameString mname
- reason = str_mname ++ " changed"
- -- We only want to look at home modules to check if any new home dependency
- -- pops in and thus here, skip modules that are not home. Checking
- -- membership in old home dependencies suffice because the `dep_missing`
- -- check already verified that all imported home modules are present there.
- if not (isOldHomeDeps mname)
- then return (UpToDate, [])
- else do
- mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do
- let mnames = mname:(map fst $ filter (not . snd) $
- dep_mods $ mi_deps imported_iface)
- case find (not . isOldHomeDeps) mnames of
- Nothing -> return (UpToDate, mnames)
- Just new_dep_mname -> do
- traceHiDiffs $
- text "imported home module " <> quotes (ppr mod) <>
- text " has a new dependency " <> quotes (ppr new_dep_mname)
- return (RecompBecause reason, [])
- return $ fromMaybe (MustCompile, []) mb_result
-
- -- Performs all recompilation checks in the list until a check that yields
- -- recompile required is encountered. Returns the list of the results of
- -- all UpToDate checks.
- runUntilRecompRequired [] = return (UpToDate, [])
- runUntilRecompRequired (check:checks) = do
- (recompile, value) <- check
- if recompileRequired recompile
- then return (recompile, [])
- else do
- (recomp, values) <- runUntilRecompRequired checks
- return (recomp, value:values)
-
- checkIfAllOldHomeDependenciesAreSeen seen_deps = do
- let unseen_old_deps = Set.difference
- old_deps
- seen_deps
- if not (null unseen_old_deps)
- then do
- let missing_dep = Set.elemAt 0 unseen_old_deps
- traceHiDiffs $
- text "missing old home dependency " <> quotes (ppr missing_dep)
- return $ RecompBecause "missing old dependency"
- else return UpToDate
-
-needInterface :: Module -> (ModIface -> IfG RecompileRequired)
- -> IfG RecompileRequired
-needInterface mod continue
- = do
- mb_recomp <- getFromModIface
- "need version info for"
- mod
- continue
- case mb_recomp of
- Nothing -> return MustCompile
- Just recomp -> return recomp
-
-getFromModIface :: String -> Module -> (ModIface -> IfG a)
- -> IfG (Maybe a)
-getFromModIface doc_msg mod getter
- = do -- Load the imported interface if possible
- let doc_str = sep [text doc_msg, ppr mod]
- traceHiDiffs (text "Checking innterface for module" <+> ppr mod)
-
- mb_iface <- loadInterface doc_str mod ImportBySystem
- -- Load the interface, but don't complain on failure;
- -- Instead, get an Either back which we can test
-
- case mb_iface of
- Failed _ -> do
- traceHiDiffs (sep [text "Couldn't load interface for module",
- ppr mod])
- return Nothing
- -- Couldn't find or parse a module mentioned in the
- -- old interface file. Don't complain: it might
- -- just be that the current module doesn't need that
- -- import and it's been deleted
- Succeeded iface -> Just <$> getter iface
-
--- | Given the usage information extracted from the old
--- M.hi file for the module being compiled, figure out
--- whether M needs to be recompiled.
-checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
-checkModUsage _this_pkg UsagePackageModule{
- usg_mod = mod,
- usg_mod_hash = old_mod_hash }
- = needInterface mod $ \iface -> do
- let reason = moduleNameString (moduleName mod) ++ " changed"
- 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
- -- a dependent package has changed.
-
-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 (mi_final_exts iface))
-
-checkModUsage this_pkg UsageHomeModule{
- usg_mod_name = mod_name,
- usg_mod_hash = old_mod_hash,
- usg_exports = maybe_old_export_hash,
- usg_entities = old_decl_hash }
- = do
- let mod = mkModule this_pkg mod_name
- needInterface mod $ \iface -> do
-
- let
- 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"
-
- -- CHECK MODULE
- recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
- if not (recompileRequired recompile)
- then return UpToDate
- else do
-
- -- CHECK EXPORT LIST
- checkMaybeHash reason maybe_old_export_hash new_export_hash
- (text " Export list changed") $ do
-
- -- CHECK ITEMS ONE BY ONE
- recompile <- checkList [ checkEntityUsage reason new_decl_hash u
- | u <- old_decl_hash]
- if recompileRequired recompile
- then return recompile -- This one failed, so just bail out now
- else up_to_date (text " Great! The bits I use are up to date")
-
-
-checkModUsage _this_pkg UsageFile{ usg_file_path = file,
- usg_file_hash = old_hash } =
- liftIO $
- handleIO handle $ do
- new_hash <- getFileHash file
- if (old_hash /= new_hash)
- then return recomp
- else return UpToDate
- where
- recomp = RecompBecause (file ++ " changed")
- handle =
-#if defined(DEBUG)
- \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
-#else
- \_ -> return recomp -- if we can't find the file, just recompile, don't fail
-#endif
-
-------------------------
-checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
- -> IfG RecompileRequired
-checkModuleFingerprint reason old_mod_hash new_mod_hash
- | new_mod_hash == old_mod_hash
- = up_to_date (text "Module fingerprint unchanged")
+-- -----------------------------------------------------------------------------
+-- Look up parents and versions of Names
- | otherwise
- = out_of_date_hash reason (text " Module fingerprint has changed")
- old_mod_hash new_mod_hash
+-- This is like a global version of the mi_hash_fn field in each ModIface.
+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
+-- the parent and version info.
-------------------------
-checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
- -> IfG RecompileRequired -> IfG RecompileRequired
-checkMaybeHash reason maybe_old_hash new_hash doc continue
- | Just hash <- maybe_old_hash, hash /= new_hash
- = out_of_date_hash reason doc hash new_hash
+mkHashFun
+ :: HscEnv -- needed to look up versions
+ -> ExternalPackageState -- ditto
+ -> (Name -> IO Fingerprint)
+mkHashFun hsc_env eps name
+ | isHoleModule orig_mod
+ = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))
| otherwise
- = continue
-
-------------------------
-checkEntityUsage :: String
- -> (OccName -> Maybe (OccName, Fingerprint))
- -> (OccName, Fingerprint)
- -> IfG RecompileRequired
-checkEntityUsage reason new_hash (name,old_hash)
- = case new_hash name of
-
- Nothing -> -- We used it before, but it ain't there now
- out_of_date reason (sep [text "No longer exported:", ppr name])
-
- Just (_, new_hash) -- It's there, but is it up to date?
- | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
- return UpToDate
- | otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name)
- old_hash new_hash
-
-up_to_date :: SDoc -> IfG RecompileRequired
-up_to_date msg = traceHiDiffs msg >> return UpToDate
-
-out_of_date :: String -> SDoc -> IfG RecompileRequired
-out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
-
-out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
-out_of_date_hash reason msg old_hash new_hash
- = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
-
-----------------------
-checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
--- This helper is used in two places
-checkList [] = return UpToDate
-checkList (check:checks) = do recompile <- check
- if recompileRequired recompile
- then return recompile
- else checkList checks
-
-{-
-************************************************************************
-* *
- Converting things to their Iface equivalents
-* *
-************************************************************************
--}
-
-tyThingToIfaceDecl :: TyThing -> IfaceDecl
-tyThingToIfaceDecl (AnId id) = idToIfaceDecl id
-tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
-tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax
-tyThingToIfaceDecl (AConLike cl) = case cl of
- RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
- PatSynCon ps -> patSynToIfaceDecl ps
-
---------------------------
-idToIfaceDecl :: Id -> IfaceDecl
--- The Id is already tidied, so that locally-bound names
--- (lambdas, for-alls) already have non-clashing OccNames
--- We can't tidy it here, locally, because it may have
--- free variables in its type or IdInfo
-idToIfaceDecl id
- = IfaceId { ifName = getName id,
- ifType = toIfaceType (idType id),
- ifIdDetails = toIfaceIdDetails (idDetails id),
- ifIdInfo = toIfaceIdInfo (idInfo id) }
-
---------------------------
-dataConToIfaceDecl :: DataCon -> IfaceDecl
-dataConToIfaceDecl dataCon
- = IfaceId { ifName = getName dataCon,
- ifType = toIfaceType (dataConUserType dataCon),
- ifIdDetails = IfVanillaId,
- ifIdInfo = [] }
-
---------------------------
-coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
--- We *do* tidy Axioms, because they are not (and cannot
--- conveniently be) built in tidy form
-coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
- , co_ax_role = role })
- = IfaceAxiom { ifName = getName ax
- , ifTyCon = toIfaceTyCon tycon
- , ifRole = role
- , ifAxBranches = map (coAxBranchToIfaceBranch tycon
- (map coAxBranchLHS branch_list))
- branch_list }
- where
- branch_list = fromBranches branches
-
--- 2nd parameter is the list of branch LHSs, in case of a closed type family,
--- for conversion from incompatible branches to incompatible indices.
--- For an open type family the list should be empty.
--- See Note [Storing compatibility] in CoAxiom
-coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
-coAxBranchToIfaceBranch tc lhs_s
- (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
- , cab_eta_tvs = eta_tvs
- , cab_lhs = lhs, cab_roles = roles
- , cab_rhs = rhs, cab_incomps = incomps })
-
- = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs
- , ifaxbCoVars = map toIfaceIdBndr cvs
- , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs
- , ifaxbLHS = toIfaceTcArgs tc lhs
- , ifaxbRoles = roles
- , ifaxbRHS = toIfaceType rhs
- , ifaxbIncomps = iface_incomps }
- where
- iface_incomps = map (expectJust "iface_incomps"
- . flip findIndex lhs_s
- . eqTypes
- . coAxBranchLHS) incomps
-
------------------
-tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
--- We *do* tidy TyCons, because they are not (and cannot
--- conveniently be) built in tidy form
--- The returned TidyEnv is the one after tidying the tyConTyVars
-tyConToIfaceDecl env tycon
- | Just clas <- tyConClass_maybe tycon
- = classToIfaceDecl env clas
-
- | Just syn_rhs <- synTyConRhs_maybe tycon
- = ( tc_env1
- , IfaceSynonym { ifName = getName tycon,
- ifRoles = tyConRoles tycon,
- ifSynRhs = if_syn_type syn_rhs,
- ifBinders = if_binders,
- ifResKind = if_res_kind
- })
-
- | Just fam_flav <- famTyConFlav_maybe tycon
- = ( tc_env1
- , IfaceFamily { ifName = getName tycon,
- ifResVar = if_res_var,
- ifFamFlav = to_if_fam_flav fam_flav,
- ifBinders = if_binders,
- ifResKind = if_res_kind,
- ifFamInj = tyConInjectivityInfo tycon
- })
-
- | isAlgTyCon tycon
- = ( tc_env1
- , IfaceData { ifName = getName tycon,
- ifBinders = if_binders,
- ifResKind = if_res_kind,
- ifCType = tyConCType tycon,
- ifRoles = tyConRoles tycon,
- ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
- ifCons = ifaceConDecls (algTyConRhs tycon),
- ifGadtSyntax = isGadtSyntaxTyCon tycon,
- ifParent = parent })
-
- | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
- -- We only convert these TyCons to IfaceTyCons when we are
- -- just about to pretty-print them, not because we are going
- -- to put them into interface files
- = ( env
- , IfaceData { ifName = getName tycon,
- ifBinders = if_binders,
- ifResKind = if_res_kind,
- ifCType = Nothing,
- ifRoles = tyConRoles tycon,
- ifCtxt = [],
- ifCons = IfDataTyCon [],
- ifGadtSyntax = False,
- ifParent = IfNoParent })
- where
- -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`
- -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
- -- an error.
- (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
- tc_tyvars = binderVars tc_binders
- if_binders = toIfaceTyCoVarBinders tc_binders
- -- No tidying of the binders; they are already tidy
- if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon)
- if_syn_type ty = tidyToIfaceType tc_env1 ty
- if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon
-
- parent = case tyConFamInstSig_maybe tycon of
- Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
- (toIfaceTyCon tc)
- (tidyToIfaceTcArgs tc_env1 tc ty)
- Nothing -> IfNoParent
-
- to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
- to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
- to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
- to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
- to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing
- to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
- = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
- where defs = fromBranches $ coAxiomBranches ax
- lhss = map coAxBranchLHS defs
- ibr = map (coAxBranchToIfaceBranch tycon lhss) defs
- axn = coAxiomName ax
-
- ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
- ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con]
- ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls AbstractTyCon = IfAbstractTyCon
- -- The AbstractTyCon case happens when a TyCon has been trimmed
- -- during tidying.
- -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
- -- for GHCi, when browsing a module, in which case the
- -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
- -- (Tuple declarations are not serialised into interface files.)
-
- ifaceConDecl data_con
- = IfCon { ifConName = dataConName data_con,
- ifConInfix = dataConIsInfix data_con,
- ifConWrapper = isJust (dataConWrapId_maybe data_con),
- ifConExTCvs = map toIfaceBndr ex_tvs',
- ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',
- ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
- ifConCtxt = tidyToIfaceContext con_env2 theta,
- ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
- ifConFields = dataConFieldLabels data_con,
- ifConStricts = map (toIfaceBang con_env2)
- (dataConImplBangs data_con),
- ifConSrcStricts = map toIfaceSrcBang
- (dataConSrcBangs data_con)}
- where
- (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
- = dataConFullSig data_con
- user_bndrs = dataConUserTyVarBinders data_con
-
- -- Tidy the univ_tvs of the data constructor to be identical
- -- to the tyConTyVars of the type constructor. This means
- -- (a) we don't need to redundantly put them into the interface file
- -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
- -- we know that the type variables will line up
- -- The latter (b) is important because we pretty-print type constructors
- -- by converting to Iface syntax and pretty-printing that
- con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
- -- A bit grimy, perhaps, but it's simple!
-
- (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs
- user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs
- to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
-
- -- By this point, we have tidied every universal and existential
- -- tyvar. Because of the dcUserTyCoVarBinders invariant
- -- (see Note [DataCon user type variable binders]), *every*
- -- user-written tyvar must be contained in the substitution that
- -- tidying produced. Therefore, tidying the user-written tyvars is a
- -- simple matter of looking up each variable in the substitution,
- -- which tidyTyCoVarOcc accomplishes.
- tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder
- tidyUserTyCoVarBinder env (Bndr tv vis) =
- Bndr (tidyTyCoVarOcc env tv) vis
-
-classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
-classToIfaceDecl env clas
- = ( env1
- , IfaceClass { ifName = getName tycon,
- ifRoles = tyConRoles (classTyCon clas),
- ifBinders = toIfaceTyCoVarBinders tc_binders,
- ifBody = body,
- ifFDs = map toIfaceFD clas_fds })
- where
- (_, clas_fds, sc_theta, _, clas_ats, op_stuff)
- = classExtraBigSig clas
- tycon = classTyCon clas
-
- body | isAbstractTyCon tycon = IfAbstractClass
- | otherwise
- = IfConcreteClass {
- ifClassCtxt = tidyToIfaceContext env1 sc_theta,
- ifATs = map toIfaceAT clas_ats,
- ifSigs = map toIfaceClassOp op_stuff,
- ifMinDef = fmap getOccFS (classMinimalDef clas)
- }
-
- (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
-
- toIfaceAT :: ClassATItem -> IfaceAT
- toIfaceAT (ATI tc def)
- = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
- where
- (env2, if_decl) = tyConToIfaceDecl env1 tc
-
- toIfaceClassOp (sel_id, def_meth)
- = ASSERT( sel_tyvars == binderVars tc_binders )
- IfaceClassOp (getName sel_id)
- (tidyToIfaceType env1 op_ty)
- (fmap toDmSpec def_meth)
- where
- -- Be careful when splitting the type, because of things
- -- like class Foo a where
- -- op :: (?x :: String) => a -> a
- -- and class Baz a where
- -- op :: (Ord a) => a -> a
- (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
- op_ty = funResultTy rho_ty
-
- toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
- toDmSpec (_, VanillaDM) = VanillaDM
- toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
-
- toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1
- ,map (tidyTyVar env1) tvs2)
-
---------------------------
-
-tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
--- If the type variable "binder" is in scope, don't re-bind it
--- In a class decl, for example, the ATD binders mention
--- (amd must mention) the class tyvars
-tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
- = case lookupVarEnv subst tv of
- Just tv' -> (env, Bndr tv' vis)
- Nothing -> tidyTyCoVarBinder env tvb
-
-tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
-tidyTyConBinders = mapAccumL tidyTyConBinder
-
-tidyTyVar :: TidyEnv -> TyVar -> FastString
-tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
-
---------------------------
-instanceToIfaceInst :: ClsInst -> IfaceClsInst
-instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
- , is_cls_nm = cls_name, is_cls = cls
- , is_tcs = mb_tcs
- , is_orphan = orph })
- = ASSERT( cls_name == className cls )
- IfaceClsInst { ifDFun = dfun_name,
- ifOFlag = oflag,
- ifInstCls = cls_name,
- ifInstTys = map do_rough mb_tcs,
- ifInstOrph = orph }
+ = lookup orig_mod
where
- do_rough Nothing = Nothing
- do_rough (Just n) = Just (toIfaceTyCon_name n)
-
- dfun_name = idName dfun_id
+ dflags = hsc_dflags hsc_env
+ hpt = hsc_HPT hsc_env
+ pit = eps_PIT eps
+ occ = nameOccName name
+ orig_mod = nameModule name
+ lookup mod = do
+ MASSERT2( isExternalName name, ppr name )
+ iface <- case lookupIfaceByModule hpt pit mod of
+ Just iface -> return iface
+ Nothing -> do
+ -- This can occur when we're writing out ifaces for
+ -- requirements; we didn't do any /real/ typechecking
+ -- so there's no guarantee everything is loaded.
+ -- Kind of a heinous hack.
+ iface <- initIfaceLoad hsc_env . withException
+ $ loadInterface (text "lookupVers2") mod ImportBySystem
+ return iface
+ return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`
+ pprPanic "lookupVers1" (ppr mod <+> ppr occ))
---------------------------
-famInstToIfaceFamInst :: FamInst -> IfaceFamInst
-famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
- fi_fam = fam,
- fi_tcs = roughs })
- = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
- , ifFamInstFam = fam
- , ifFamInstTys = map do_rough roughs
- , ifFamInstOrph = orph }
- where
- do_rough Nothing = Nothing
- do_rough (Just n) = Just (toIfaceTyCon_name n)
-
- fam_decl = tyConName $ coAxiomTyCon axiom
- mod = ASSERT( isExternalName (coAxiomName axiom) )
- nameModule (coAxiomName axiom)
- is_local name = nameIsLocalOrFrom mod name
-
- lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
-
- orph | is_local fam_decl
- = NotOrphan (nameOccName fam_decl)
- | otherwise
- = chooseOrphanAnchor lhs_names
-
---------------------------
-coreRuleToIfaceRule :: CoreRule -> IfaceRule
-coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
- = pprTrace "toHsRule: builtin" (ppr fn) $
- bogusIfaceRule fn
-
-coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
- ru_act = act, ru_bndrs = bndrs,
- ru_args = args, ru_rhs = rhs,
- ru_orphan = orph, ru_auto = auto })
- = IfaceRule { ifRuleName = name, ifActivation = act,
- ifRuleBndrs = map toIfaceBndr bndrs,
- ifRuleHead = fn,
- ifRuleArgs = map do_arg args,
- ifRuleRhs = toIfaceExpr rhs,
- ifRuleAuto = auto,
- ifRuleOrph = orph }
+-- | Creates cached lookup for the 'mi_anns' field of ModIface
+-- Hackily, we use "module" as the OccName for any module-level annotations
+mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
+mkIfaceAnnCache anns
+ = \n -> lookupOccEnv env n `orElse` []
where
- -- For type args we must remove synonyms from the outermost
- -- level. Reason: so that when we read it back in we'll
- -- construct the same ru_rough field as we have right now;
- -- see tcIfaceRule
- do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
- do_arg (Coercion co) = IfaceCo (toIfaceCoercion co)
- do_arg arg = toIfaceExpr arg
-
-bogusIfaceRule :: Name -> IfaceRule
-bogusIfaceRule id_name
- = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
- ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
- ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
- ifRuleAuto = True }
+ pair (IfaceAnnotation target value) =
+ (case target of
+ NamedTarget occn -> occn
+ ModuleTarget _ -> mkVarOcc "module"
+ , [value])
+ -- flipping (++), so the first argument is always short
+ env = mkOccEnv_C (flip (++)) (map pair anns)
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 5c6aeab0e9..ebc88c272b 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -1417,7 +1417,7 @@ instance Outputable IfaceUnfolding where
* *
************************************************************************
-This is used for dependency analysis in GHC.Iface.Utils, so that we
+This is used for dependency analysis in GHC.Iface.Make, so that we
fingerprint a declaration before the things that depend on it. It
is specific to interface-file fingerprinting in the sense that we
don't collect *all* Names: for example, the DFun of an instance is
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 17b2334e2b..f027a234e2 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -356,7 +356,8 @@ Library
GHC.Iface.Type
GHC.CoreToIface
GHC.Iface.Load
- GHC.Iface.Utils
+ GHC.Iface.Make
+ GHC.Iface.Recomp
GHC.IfaceToCore
FlagChecker
Annotations
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
index f16bb27b05..55ceb047a8 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/prelude/PrelInfo.hs
@@ -100,7 +100,7 @@ Note [About wired-in things]
checker sees if the Name is wired in before looking up the name in
the type environment.
-* GHC.Iface.Utils prunes out wired-in things before putting them in an interface file.
+* GHC.Iface.Make prunes out wired-in things before putting them in an interface file.
So interface files never contain wired-in things.
-}
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index aff3ff4ee2..2423805f8e 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -88,7 +88,7 @@ import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons
, famInstEnvElts, extendFamInstEnvList, normaliseType )
import TcAnnotations
import TcBinds
-import GHC.Iface.Utils ( coAxiomToIfaceDecl )
+import GHC.Iface.Make ( coAxiomToIfaceDecl )
import HeaderInfo ( mkPrelImports )
import TcDefaults
import TcEnv
@@ -1837,7 +1837,7 @@ being called "Main.main". That's why root_main_id has a fixed module
":Main".)
This is unusual: it's a LocalId whose Name has a Module from another
-module. Tiresomely, we must filter it out again in GHC.Iface.Utils, less we
+module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we
get two defns for 'main' in the interface file!
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 856dfa7f14..13f4e6fd89 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -384,7 +384,7 @@ data FrontendResult
--
-- - For any code involving Names, we want semantic modules.
-- See lookupIfaceTop in GHC.Iface.Env, mkIface and addFingerprints
--- in GHC.Iface.Utils, and tcLookupGlobal in TcEnv
+-- in GHC.Iface.{Make,Recomp}, and tcLookupGlobal in TcEnv
--
-- - When reading interfaces, we want the identity module to
-- identify the specific interface we want (such interfaces
@@ -664,7 +664,7 @@ We gather three sorts of usage information
Used (a) to report "defined but not used"
(see GHC.Rename.Names.reportUnusedNames)
(b) to generate version-tracking usage info in interface
- files (see GHC.Iface.Utils.mkUsedNames)
+ files (see GHC.Iface.Make.mkUsedNames)
This usage info is mainly gathered by the renamer's
gathering of free-variables
diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs
index 67325558b6..6fcdc8e246 100644
--- a/compiler/types/InstEnv.hs
+++ b/compiler/types/InstEnv.hs
@@ -320,7 +320,7 @@ mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan
{-
Note [When exactly is an instance decl an orphan?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- (see GHC.Iface.Utils.instanceToIfaceInst, which implements this)
+ (see GHC.Iface.Make.instanceToIfaceInst, which implements this)
Roughly speaking, an instance is an orphan if its head (after the =>)
mentions nothing defined in this module.