diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs index ed9f4cd3715cce5c4622661206554f7a0aaf481d..3252f18419916e5083870b051bbb690cbcdb0328 100644 --- a/compiler/deSugar/DsUsage.hs +++ b/compiler/deSugar/DsUsage.hs @@ -319,10 +319,10 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names -- modules accumulate in the PIT not HPT. Sigh. Just iface = maybe_iface - finsts_mod = mi_finsts (mi_final_exts iface) - hash_env = mi_hash_fn (mi_final_exts iface) - mod_hash = mi_mod_hash (mi_final_exts iface) - export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface)) + finsts_mod = mi_finsts iface + hash_env = mi_hash_fn iface + mod_hash = mi_mod_hash iface + export_hash | depend_on_exports = Just (mi_exp_hash iface) | otherwise = Nothing by_is_safe (ImportedByUser imv) = imv_is_safe imv diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 176b6cd0d04898f02430ae2069fbfcb0d73f1376..ab62292462d4fdaf17f67932876dabcbaca2c5a6 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -423,7 +423,7 @@ loadInterface doc_str mod from Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod ; case read_result of { Failed err -> do - { let fake_iface = emptyFullModIface mod + { let fake_iface = emptyModIface mod ; updateEps_ $ \eps -> eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } @@ -473,14 +473,13 @@ loadInterface doc_str mod from ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) - ; let { final_iface = iface { - mi_decls = panic "No mi_decls in PIT", - mi_insts = panic "No mi_insts in PIT", - mi_fam_insts = panic "No mi_fam_insts in PIT", - mi_rules = panic "No mi_rules in PIT", - mi_anns = panic "No mi_anns in PIT" - } - } + ; let final_iface = iface{ + mi_decls = panic "No mi_decls in PIT", + mi_insts = panic "No mi_insts in PIT", + mi_fam_insts = panic "No mi_fam_insts in PIT", + mi_rules = panic "No mi_rules in PIT", + mi_anns = panic "No mi_anns in PIT" + } ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod -- Warn warn against an EPS-updating import @@ -965,7 +964,7 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file r <- read_file dynFilePath case r of Succeeded (dynIface, _) - | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) -> + | mi_mod_hash iface == mi_mod_hash dynIface -> return () | otherwise -> do traceIf (text "Dynamic hash doesn't match") @@ -1040,13 +1039,12 @@ initExternalPackageState ghcPrimIface :: ModIface ghcPrimIface = empty_iface { - mi_exports = ghcPrimExports, - mi_decls = [], mi_fixities = fixities, - mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities } + mi_fix_fn = mkIfaceFixCache fixities, + mi_exports = ghcPrimExports } where - empty_iface = emptyFullModIface gHC_PRIM + empty_iface = emptyModIface gHC_PRIM -- The fixities listed here for @`seq`@ or @->@ should match -- those in primops.txt.pp (from which Haddock docs are generated). @@ -1116,25 +1114,28 @@ showIface hsc_env filename = do -- Show a ModIface but don't display details; suitable for ModIfaces stored in -- the EPT. pprModIfaceSimple :: ModIface -> SDoc -pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface))) +pprModIfaceSimple iface = + ppr (mi_module iface) $$ + pprDeps (mi_deps iface) $$ + nest 2 (vcat (map pprExport (mi_exports iface))) pprModIface :: ModIface -> SDoc -- Show a ModIface -pprModIface iface@ModIface{ mi_final_exts = exts } +pprModIface iface = vcat [ text "interface" <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) - <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty) - <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty) + <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty) + <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty) <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty) <+> integer hiVersion - , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts)) - , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts)) - , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts)) - , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts)) - , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts)) - , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts)) - , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts)) - , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts)) + , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface)) + , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) + , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface)) + , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) + , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface)) + , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash iface)) + , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash iface)) + , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash iface)) , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) , nest 2 (text "where") diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 02948d67c892da8e5f1addef59253ae5ba6f9e5c..65d97ecbf1a3919c81cf7443b714de773212eaa7 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -10,9 +10,8 @@ -- writing them to disk and comparing two versions to see if -- recompilation is required. module MkIface ( - mkPartialIface, - mkFullIface, - + mkModDetails, + mkIface, mkIfaceTc, writeIfaceFile, -- Write the interface file @@ -70,6 +69,7 @@ import FlagChecker import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies ) import Id +import IdInfo import Annotations import CoreSyn import Class @@ -110,6 +110,10 @@ import Exception import UniqSet import Packages import ExtractDocs +import PprCore (pprRules) + +import TidyPgm +import CoreTidy import Control.Monad import Data.Function @@ -123,8 +127,6 @@ import System.FilePath import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..), pluginRecompile', plugins ) ---Qualified import so we can define a Semigroup instance --- but it doesn't clash with Outputable.<> import qualified Data.Semigroup {- @@ -135,41 +137,108 @@ import qualified Data.Semigroup ************************************************************************ -} -mkPartialIface :: HscEnv - -> ModDetails - -> ModGuts - -> PartialModIface -mkPartialIface hsc_env mod_details - ModGuts{ mg_module = this_mod - , mg_hsc_src = hsc_src - , mg_usages = usages - , mg_used_th = used_th - , mg_deps = deps - , mg_rdr_env = rdr_env - , mg_fix_env = fix_env - , mg_warns = warns - , mg_hpc_info = hpc_info - , mg_safe_haskell = safe_mode - , mg_trust_pkg = self_trust - , mg_doc_hdr = doc_hdr - , mg_decl_docs = decl_docs - , mg_arg_docs = arg_docs - } - = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust - safe_mode usages doc_hdr decl_docs arg_docs mod_details - --- | Fully instantiate a interface --- Adds fingerprints and potentially code generator produced information. -mkFullIface :: HscEnv -> PartialModIface -> IO ModIface -mkFullIface hsc_env partial_iface = do - full_iface <- +mkModDetails :: HscEnv -> CgModGuts -> CgGuts -> ModDetails +mkModDetails hsc_env desugared_guts cg_guts = + let + CgModGuts { cg_mg_tcs = mg_tcs + , cg_mg_fam_insts = mg_fam_insts + , cg_mg_patsyns = mg_patsyns + , cg_mg_insts = mg_insts + , cg_mg_exports = mg_exports + , cg_mg_anns = mg_anns + , cg_mg_complete_sigs = mg_complete_sigs + } = desugared_guts + + CgGuts { cg_tidy_binds = tidy_binds + , cg_tidy_env = tidy_env + , cg_trimmed_rules = trimmed_rules + } = cg_guts + + dflags = hsc_dflags hsc_env + + -- The completed type environment is gotten from + -- a) the types and classes defined here (plus implicit things) + -- b) adding Ids with correct IdInfo, including unfoldings, + -- gotten from the bindings + -- From (b) we keep only those Ids with External names; + -- the CoreTidy pass makes sure these are all and only + -- the externally-accessible ones + -- This truncates the type environment to include only the + -- exported Ids and things needed from them, which saves space + -- + -- See Note [Don't attempt to trim data types] + omit_prags = gopt Opt_OmitInterfacePragmas dflags + + trim_id :: Id -> Id + trim_id id + | not (isImplicitId id) + = id `setIdInfo` vanillaIdInfo + | otherwise + = id + + final_ids = [ if omit_prags then trim_id id else id + | id <- bindersOfBinds tidy_binds + , isExternalName (idName id) + , not (isWiredInName (getName id)) + ] -- See Note [Drop wired-in things] + final_tcs = filterOut (isWiredInName . getName) mg_tcs + -- See Note [Drop wired-in things] + type_env = typeEnvFromEntities final_ids final_tcs mg_fam_insts + + tidy_patsyns = mkFinalPatSyns type_env mg_patsyns + tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env + tidy_rules = tidyRules tidy_env trimmed_rules + tidy_cls_insts = mkFinalClsInsts type_env mg_insts + in + ModDetails + { md_types = tidy_type_env + , md_rules = tidy_rules + , md_insts = tidy_cls_insts + , md_fam_insts = mg_fam_insts + , md_exports = mg_exports + , md_anns = mg_anns + , md_complete_sigs = mg_complete_sigs + } + +mkIface :: HscEnv -> CgModGuts -> ModDetails -> IO ModIface +mkIface hsc_env desugared_guts mod_details = do + + let CgModGuts + { cg_mg_module = this_mod + , cg_mg_hsc_src = hsc_src + , cg_mg_usages = usages + , cg_mg_used_th = used_th + , cg_mg_deps = deps + , cg_mg_rdr_env = rdr_env + , cg_mg_fix_env = fix_env + , cg_mg_warns = warns + , cg_mg_hpc_info = hpc_info + , cg_mg_safe_haskell = safe_mode + , cg_mg_trust_pkg = self_trust + , cg_mg_doc_hdr = doc_hdr + , cg_mg_decl_docs = decl_docs + , cg_mg_arg_docs = arg_docs + } = desugared_guts + + let dflags = hsc_dflags hsc_env + + let tidy_rules = md_rules mod_details + unless (null tidy_rules) $ + dumpIfSet_any dflags [Opt_D_dump_simpl, Opt_D_dump_rules] + (showSDoc dflags (text "Tidy Rules")) + FormatText + (pprRules tidy_rules) + + iface <- {-# SCC "addFingerprints" #-} - addFingerprints hsc_env partial_iface + mkIface_ + hsc_env mod_details 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 -- Debug printing - dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface) + dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface iface) - return full_iface + return iface -- | Make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any @@ -213,126 +282,10 @@ mkIfaceTc hsc_env safe_mode mod_details 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 - -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 - -- are going to be for , 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 + mkIface_ + hsc_env mod_details 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 ----------------------------- writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO () @@ -375,7 +328,7 @@ mkHashFun hsc_env eps name iface <- initIfaceLoad hsc_env . withException $ loadInterface (text "lookupVers2") mod ImportBySystem return iface - return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse` + return $ snd (mi_hash_fn iface occ `orElse` pprPanic "lookupVers1" (ppr mod <+> ppr occ)) -- --------------------------------------------------------------------------- @@ -404,24 +357,91 @@ fingerprint; in the binding case we shouldn't since it is merely the name of the thing that we are currently fingerprinting. -} --- | Add fingerprints for top-level declarations to a 'ModIface'. --- --- See Note [Fingerprinting IfaceDecls] -addFingerprints +mkIface_ :: HscEnv - -> PartialModIface + -> ModDetails + -> Module + -> HscSource + -> Bool + -> Dependencies + -> GlobalRdrEnv + -> NameEnv FixItem + -> Warnings + -> HpcInfo + -> Bool + -> SafeHaskellMode + -> [Usage] + -> Maybe HsDocString + -> DeclDocMap + -> ArgDocMap -> IO ModIface -addFingerprints hsc_env iface0 - = do +mkIface_ hsc_env mod_details 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 = do + + let dflags = hsc_dflags hsc_env + let semantic_mod = canonicalizeHomeModule dflags (moduleName this_mod) + + let 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 } = mod_details + + let cmp_rule = comparing ifRuleName + let cmp_fam_inst = comparing (nameOccName . ifFamInstFam) + -- Compare these lexicographically by OccName, *not* by unique, + -- because the latter is not stable across compilations: + let cmp_inst = comparing (nameOccName . ifDFun) + + let iface_exports = mkIfaceExports exports + let iface_fam_insts = sortBy cmp_fam_inst (map famInstToIfaceFamInst fam_insts) + let iface_insts = sortBy cmp_inst (map instanceToIfaceInst (fixSafeInstances safe_mode insts)) + let iface_rules = sortBy cmp_rule (map coreRuleToIfaceRule rules) + let iface_anns = map mkIfaceAnnotation anns + let iface_complete_sigs = map mkIfaceCompleteSig complete_sigs + let iface_trust = setSafeMode safe_mode + + let (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph iface_insts + let (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph iface_rules + let (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph iface_fam_insts + let ann_fn = mkIfaceAnnCache iface_anns + + + -- Add fingerprints for top-level declarations to a 'ModIface'. + -- + -- See Note [Fingerprinting IfaceDecls] eps <- hscEPS hsc_env let - decls = mi_decls iface0 - warn_fn = mkIfaceWarnCache (mi_warns iface0) - fix_fn = mkIfaceFixCache (mi_fixities iface0) + 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 + -- are going to be for , not the former id! + -- See Note [Identity versus semantic module] - -- The ABI of a declaration represents everything that is made - -- visible about the declaration that a client can depend on. - -- see IfaceDeclABI below. + warn_fn = mkIfaceWarnCache src_warns + + 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. + -- + fix_fn = mkIfaceFixCache fixities + + -- The ABI of a declaration represents everything that is made + -- visible about the declaration that a client can depend on. + -- see IfaceDeclABI below. declABI :: IfaceDecl -> IfaceDeclABI -- TODO: I'm not sure if this should be semantic_mod or this_mod. -- See also Note [Identity versus semantic module] @@ -557,7 +577,7 @@ addFingerprints hsc_env iface0 -- when calculating fingerprints, we always need to use canonical -- ordering for lists of things. In particular, the mi_deps has various -- lists of modules and suchlike, so put these all in canonical order: - let sorted_deps = sortDependencies (mi_deps iface0) + let sorted_deps = sortDependencies deps -- The export hash of a module depends on the orphan hashes of the -- orphan modules below us in the dependency tree. This is the way @@ -604,15 +624,15 @@ addFingerprints hsc_env iface0 -- the export list hash doesn't depend on the fingerprints of -- the Names it mentions, only the Names themselves, hence putNameLiterally. export_hash <- computeFingerprint putNameLiterally - (mi_exports iface0, + (iface_exports, orphan_hash, dep_orphan_hashes, - dep_pkgs (mi_deps iface0), + dep_pkgs deps, -- See Note [Export hash depends on non-orphan family instances] - dep_finsts (mi_deps iface0), + dep_finsts deps, -- dep_pkgs: see "Package Version Changes" on -- wiki/commentary/compiler/recompilation-avoidance - mi_trust iface0) + iface_trust) -- Make sure change of Safe Haskell mode causes recomp. -- Note [Export hash depends on non-orphan family instances] @@ -668,7 +688,7 @@ addFingerprints hsc_env iface0 mod_hash <- computeFingerprint putNameLiterally (map fst sorted_decls, export_hash, -- includes orphan_hash - mi_warns iface0) + src_warns) -- The interface hash depends on: -- - the ABI hash, plus @@ -679,41 +699,68 @@ addFingerprints hsc_env iface0 iface_hash <- computeFingerprint putNameLiterally (mod_hash, ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache - mi_usages iface0, + usages, sorted_deps, - mi_hpc iface0) + isHpcUsed hpc_info) + let - final_iface_exts = ModIfaceBackend - { mi_iface_hash = iface_hash - , mi_mod_hash = mod_hash - , mi_flag_hash = flag_hash - , mi_opt_hash = opt_hash - , mi_hpc_hash = hpc_hash - , mi_plugin_hash = plugin_hash - , mi_orphan = not ( all ifRuleAuto orph_rules - -- See Note [Orphans and auto-generated rules] - && null orph_insts - && null orph_fis) - , mi_finsts = not (null (mi_fam_insts iface0)) - , mi_exp_hash = export_hash - , mi_orphan_hash = orphan_hash - , mi_warn_fn = warn_fn - , mi_fix_fn = fix_fn - , mi_hash_fn = lookupOccEnv local_env - } - final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts } - -- - return final_iface + -- 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 + + return ModIface + { mi_iface_hash = iface_hash + , mi_mod_hash = mod_hash + , mi_flag_hash = flag_hash + , mi_opt_hash = opt_hash + , mi_hpc_hash = hpc_hash + , mi_plugin_hash = plugin_hash + , mi_orphan = not ( all ifRuleAuto orph_rules + -- See Note [Orphans and auto-generated rules] + && null orph_insts + && null orph_fis) + , mi_finsts = not (null iface_fam_insts) + , mi_exp_hash = export_hash + , mi_orphan_hash = orphan_hash + , mi_warn_fn = warn_fn + , mi_fix_fn = fix_fn + , mi_hash_fn = lookupOccEnv local_env + , mi_exports = iface_exports + , mi_insts = iface_insts + , mi_fam_insts = iface_fam_insts + , mi_rules = iface_rules + , mi_anns = iface_anns + , mi_complete_sigs = iface_complete_sigs + , mi_decls = sorted_decls + , 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_fixities = fixities + , mi_warns = src_warns + , mi_globals = maybeGlobalRdrEnv rdr_env + , mi_used_th = used_th + , mi_hpc = isHpcUsed hpc_info + , mi_trust = setSafeMode safe_mode + , mi_trust_pkg = pkg_trust_req + , mi_doc_hdr = doc_hdr + , mi_decl_docs = decl_docs + , mi_arg_docs = arg_docs + } - where - this_mod = mi_module iface0 - semantic_mod = mi_semantic_module iface0 - dflags = hsc_dflags hsc_env - (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) - (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) - (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) - ann_fn = mkIfaceAnnCache (mi_anns iface0) -- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules -- (in particular, the orphan modules which are transitively imported by the @@ -753,11 +800,11 @@ getOrphanHashes hsc_env mods = do pit = eps_PIT eps get_orph_hash mod = case lookupIfaceByModule hpt pit mod of - Just iface -> return (mi_orphan_hash (mi_final_exts iface)) + Just iface -> return (mi_orphan_hash iface) Nothing -> do -- similar to 'mkHashFun' iface <- initIfaceLoad hsc_env . withException $ loadInterface (text "getOrphanHashes") mod ImportBySystem - return (mi_orphan_hash (mi_final_exts iface)) + return (mi_orphan_hash iface) -- mapM get_orph_hash mods @@ -1291,7 +1338,7 @@ checkVersions hsc_env mod_summary iface checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired checkPlugins hsc iface = liftIO $ do new_fingerprint <- fingerprintPlugins hsc - let old_fingerprint = mi_plugin_hash (mi_final_exts iface) + let old_fingerprint = mi_plugin_hash iface pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc)) return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr @@ -1388,7 +1435,7 @@ checkHie mod_summary = do -- | Check the flags haven't changed checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do - let old_hash = mi_flag_hash (mi_final_exts iface) + let old_hash = mi_flag_hash iface new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) (mi_module iface) putNameLiterally @@ -1401,7 +1448,7 @@ checkFlagHash hsc_env iface = do -- | Check the optimisation flags haven't changed checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired checkOptimHash hsc_env iface = do - let old_hash = mi_opt_hash (mi_final_exts iface) + let old_hash = mi_opt_hash iface new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env) putNameLiterally if | old_hash == new_hash @@ -1416,7 +1463,7 @@ checkOptimHash hsc_env iface = do -- | Check the HPC flags haven't changed checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired checkHpcHash hsc_env iface = do - let old_hash = mi_hpc_hash (mi_final_exts iface) + let old_hash = mi_hpc_hash iface new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env) putNameLiterally if | old_hash == new_hash @@ -1599,7 +1646,7 @@ checkModUsage _this_pkg UsagePackageModule{ usg_mod_hash = old_mod_hash } = needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed" - checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + checkModuleFingerprint reason old_mod_hash (mi_mod_hash 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 @@ -1608,7 +1655,7 @@ checkModUsage _this_pkg UsagePackageModule{ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed (raw)" - checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) checkModUsage this_pkg UsageHomeModule{ usg_mod_name = mod_name, @@ -1620,9 +1667,9 @@ checkModUsage this_pkg UsageHomeModule{ 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) + new_mod_hash = mi_mod_hash iface + new_decl_hash = mi_hash_fn iface + new_export_hash = mi_exp_hash iface reason = moduleNameString mod_name ++ " changed" diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 62a4826edb197f1c6591f22ebf9a52b09c971254..5a84bd82ab1fa7cde4602f991c477d8979cc5a12 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -66,7 +66,7 @@ import FileCleanup import Ar import Bag ( unitBag ) import FastString ( mkFastString ) -import MkIface ( mkFullIface ) +import MkIface ( mkIface, mkModDetails ) import Exception import System.Directory @@ -218,18 +218,19 @@ compileOne' m_tc_result mHscMessage o_time <- getModificationUTCTime object_filename let !linkable = LM o_time this_mod [DotO object_filename] return $! HomeModInfo iface hmi_details (Just linkable) - (HscRecomp { hscs_guts = cgguts, + (HscRecomp { hscs_guts = cg_guts, hscs_mod_location = mod_location, - hscs_mod_details = hmi_details, - hscs_partial_iface = partial_iface, + hscs_desugared_guts = desugared_guts, hscs_old_iface_hash = mb_old_iface_hash, hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do -- In interpreted mode the regular codeGen backend is not run so we -- generate a interface without codeGen info. - final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface - liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash mod_location + let iface_hsc_env = hsc_env'{hsc_dflags=iface_dflags} + let mod_details = mkModDetails iface_hsc_env desugared_guts cg_guts + iface <- mkIface iface_hsc_env desugared_guts mod_details + liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash mod_location - (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location + (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cg_guts mod_location stub_o <- case hasStub of Nothing -> return [] @@ -247,7 +248,7 @@ compileOne' m_tc_result mHscMessage -- be out of date. let !linkable = LM unlinked_time (ms_mod summary) (hs_unlinked ++ stub_o) - return $! HomeModInfo final_iface hmi_details (Just linkable) + return $! HomeModInfo iface mod_details (Just linkable) (HscRecomp{}, _) -> do output_fn <- getOutputFilename next_phase (Temporary TFL_CurrentModule) @@ -1176,10 +1177,9 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do basename = dropExtension input_fn liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name return (RealPhase StopLn, o_file) - HscRecomp { hscs_guts = cgguts, + HscRecomp { hscs_guts = cg_guts, hscs_mod_location = mod_location, - hscs_mod_details = mod_details, - hscs_partial_iface = partial_iface, + hscs_desugared_guts = desugared_guts, hscs_old_iface_hash = mb_old_iface_hash, hscs_iface_dflags = iface_dflags } -> do output_fn <- phaseOutputFilename next_phase @@ -1187,18 +1187,16 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do PipeState{hsc_env=hsc_env'} <- getPipeState (outputFilename, mStub, foreign_files) <- liftIO $ - hscGenHardCode hsc_env' cgguts mod_location output_fn + hscGenHardCode hsc_env' cg_guts mod_location output_fn - final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface) - -- TODO(osa): ModIface and ModDetails need to be in sync, - -- but we only generate ModIface with the backend info. See - -- !2100 for more discussion on this. This will be fixed - -- with !1304 or !2100. - setIface final_iface mod_details + let iface_hsc_env = hsc_env'{hsc_dflags=iface_dflags} + let mod_details = mkModDetails iface_hsc_env desugared_guts cg_guts + iface <- liftIO (mkIface iface_hsc_env desugared_guts mod_details) + setIface iface mod_details -- See Note [Writing interface files] let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo - liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location + liftIO $ hscMaybeWriteIface if_dflags iface mb_old_iface_hash mod_location stub_o <- liftIO (mapM (compileStub hsc_env') mStub) foreign_os <- liftIO $ diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index b5dab7ea3546cb1b22d2bd918c3f1dba2925507f..be9c0795b12ddd7727f6cdb6512ed44e12489666 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -41,7 +41,7 @@ module ErrUtils ( getCaretDiagnostic, -- * Dump files - dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, + dumpIfSet, dumpIfSet_dyn, dumpIfSet_any, dumpIfSet_dyn_printer, dumpOptionsFromFlag, DumpOptions (..), DumpFormat (..), DumpAction, dumpAction, defaultDumpAction, TraceAction, traceAction, defaultTraceAction, @@ -451,6 +451,16 @@ dumpIfSet dflags flag hdr doc dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify +dumpIfSet_any :: DynFlags -> [DumpFlag] -> String -> DumpFormat -> SDoc -> IO () +dumpIfSet_any dflags flags hdr fmt doc = go flags + where + go [] = return () + go (f : fs) + | dopt f dflags + = dumpAction dflags (mkDumpStyle dflags alwaysQualify) (dumpOptionsFromFlag f) hdr fmt doc + | otherwise + = go fs + -- | a wrapper around 'dumpAction'. -- First check whether the dump flag is set -- Do nothing if it is unset diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index def7065ab67e6e0fcf539ceaf555b8827c1b1f66..4b70243bf7f0152bebe5c41bd99fb4581633ff96 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -85,7 +85,7 @@ module GHC ( lookupGlobalName, findGlobalAnns, mkPrintUnqualifiedForModule, - ModIface, ModIface_(..), + ModIface(..), SafeHaskellMode(..), -- * Querying the environment @@ -359,6 +359,7 @@ import TcRnDriver import Inst import FamInst import FileCleanup +import MkIface ( mkModDetails ) import Data.Foldable import qualified Data.Map.Strict as Map @@ -1056,7 +1057,8 @@ compileCore simplify fn = do plugins <- readIORef (tcg_th_coreplugins tcg) hscSimplify hsc_env plugins mod_guts tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts - return $ Left tidy_guts + let mod_details = mkModDetails hsc_env (mkCgModGuts simpl_guts) tidy_guts + return $ Left (tidy_guts, mod_details) else return $ Right mod_guts diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 81f3caa0331699d8c772cae6597052415b577d2f..622944706e4bfb975c9824a34eae1efb091af93f 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -173,7 +173,6 @@ import System.IO (fixIO) import qualified Data.Map as M import qualified Data.Set as S import Data.Set (Set) -import Control.DeepSeq (force) import HieAst ( mkHieFile ) import HieTypes ( getAsts, hie_asts, hie_module ) @@ -673,7 +672,7 @@ hscIncrementalFrontend -- save the interface that comes back from checkOldIface. -- In one-shot mode we don't have the old iface until this -- point, when checkOldIface reads it from the disk. - let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface + let mb_old_hash = fmap mi_iface_hash mb_checked_iface case mb_checked_iface of Just iface | not (recompileRequired recomp_reqd) -> @@ -828,21 +827,14 @@ finish summary tc_result mb_old_hash = do plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) desugared_guts <- hscSimplify' plugins desugared_guts0 - (cg_guts, details) <- {-# SCC "CoreTidy" #-} + cg_guts <- {-# SCC "CoreTidy" #-} liftIO $ tidyProgram hsc_env desugared_guts - let !partial_iface = - {-# SCC "HscMain.mkPartialIface" #-} - -- This `force` saves 2M residency in test T10370 - -- See Note [Avoiding space leaks in toIface*] for details. - force (mkPartialIface hsc_env details desugared_guts) - - return HscRecomp { hscs_guts = cg_guts, - hscs_mod_location = ms_location summary, - hscs_mod_details = details, - hscs_partial_iface = partial_iface, - hscs_old_iface_hash = mb_old_hash, - hscs_iface_dflags = dflags } + return $! HscRecomp{ hscs_guts = cg_guts, + hscs_mod_location = ms_location summary, + hscs_desugared_guts = mkCgModGuts desugared_guts, + hscs_old_iface_hash = mb_old_hash, + hscs_iface_dflags = dflags } else mk_simple_iface @@ -867,7 +859,7 @@ hscMaybeWriteIface dflags iface old_iface location = do HscNothing -> False HscInterpreted -> False _ -> True - no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) + no_change = old_iface == Just (mi_iface_hash iface) when (write_interface || force_write_interface) $ hscWriteIface dflags iface no_change location @@ -1703,7 +1695,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do hscSimplify hsc_env plugins ds_result {- Tidy -} - (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg + tidy_cg <- liftIO $ tidyProgram hsc_env simpl_mg let !CgGuts{ cg_module = this_mod, cg_binds = core_binds, @@ -1711,7 +1703,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do cg_modBreaks = mod_breaks } = tidy_cg !ModDetails { md_insts = cls_insts - , md_fam_insts = fam_insts } = mod_details + , md_fam_insts = fam_insts } = mkModDetails hsc_env (mkCgModGuts simpl_mg) tidy_cg -- Get the *tidied* cls_insts and fam_insts data_tycons = filter isDataTyCon tycons diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index d1e06030886d8abab00af6f9db1a47b354fe2067..d7b3e2380858c409d354d26927779269658c6714 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -34,7 +34,7 @@ module HscTypes ( -- * Information about modules ModDetails(..), emptyModDetails, - ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, + ModGuts(..), CgModGuts(..), mkCgModGuts, CgGuts(..), ForeignStubs(..), appendStubC, ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..), ForeignSrcLang(..), phaseForeignLanguage, @@ -59,7 +59,7 @@ module HscTypes ( -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, - lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule, + lookupIfaceByModule, emptyModIface, lookupHptByModule, PackageInstEnv, PackageFamInstEnv, PackageRuleBase, PackageCompleteMatchMap, @@ -86,7 +86,7 @@ module HscTypes ( mkQualPackage, mkQualModule, pkgQual, -- * Interfaces - ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..), + ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, emptyIfaceWarnCache, mi_boot, mi_fix, mi_semantic_module, @@ -214,6 +214,7 @@ import Util import UniqDSet import GHC.Serialized ( Serialized ) import qualified GHC.LanguageExtensions as LangExt +import VarEnv (TidyEnv) import Foreign import Control.Monad ( guard, liftM, ap ) @@ -223,7 +224,6 @@ import Exception import System.FilePath import Control.Concurrent import System.Process ( ProcessHandle ) -import Control.DeepSeq -- ----------------------------------------------------------------------------- -- Compilation state @@ -241,13 +241,11 @@ data HscStatus | HscUpdateSig ModIface ModDetails -- | Recompile this module. | HscRecomp - { hscs_guts :: CgGuts + { hscs_guts :: !CgGuts -- ^ Information for the code generator. , hscs_mod_location :: !ModLocation -- ^ Module info - , hscs_mod_details :: !ModDetails - , hscs_partial_iface :: !PartialModIface - -- ^ Partial interface + , hscs_desugared_guts :: !CgModGuts , hscs_old_iface_hash :: !(Maybe Fingerprint) -- ^ Old interface hash for this compilation, if an old interface file -- exists. Pass to `hscMaybeWriteIface` when writing the interface to @@ -888,86 +886,6 @@ data FindResult ************************************************************************ -} -{- Note [Interface file stages] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Interface files have two possible stages. - -* A partial stage built from the result of the core pipeline. -* A fully instantiated form. Which also includes fingerprints and - potentially information provided by backends. - -We can build a full interface file two ways: -* Directly from a partial one: - Then we omit backend information and mostly compute fingerprints. -* From a partial one + information produced by a backend. - Then we store the provided information and fingerprint both. --} - -type PartialModIface = ModIface_ 'ModIfaceCore -type ModIface = ModIface_ 'ModIfaceFinal - --- | Extends a PartialModIface with information which is either: --- * Computed after codegen --- * Or computed just before writing the iface to disk. (Hashes) --- In order to fully instantiate it. -data ModIfaceBackend = ModIfaceBackend - { mi_iface_hash :: !Fingerprint - -- ^ Hash of the whole interface - , mi_mod_hash :: !Fingerprint - -- ^ Hash of the ABI only - , mi_flag_hash :: !Fingerprint - -- ^ Hash of the important flags used when compiling the module, excluding - -- optimisation flags - , mi_opt_hash :: !Fingerprint - -- ^ Hash of optimisation flags - , mi_hpc_hash :: !Fingerprint - -- ^ Hash of hpc flags - , mi_plugin_hash :: !Fingerprint - -- ^ Hash of plugins - , mi_orphan :: !WhetherHasOrphans - -- ^ Whether this module has orphans - , mi_finsts :: !WhetherHasFamInst - -- ^ Whether this module has family instances. See Note [The type family - -- instance consistency story]. - , mi_exp_hash :: !Fingerprint - -- ^ Hash of export list - , mi_orphan_hash :: !Fingerprint - -- ^ Hash for orphan rules, class and family instances combined - - -- Cached environments for easy lookup. These are computed (lazily) from - -- other fields and are not put into the interface file. - -- Not really produced by the backend but there is no need to create them - -- any earlier. - , mi_warn_fn :: !(OccName -> Maybe WarningTxt) - -- ^ Cached lookup for 'mi_warns' - , mi_fix_fn :: !(OccName -> Maybe Fixity) - -- ^ Cached lookup for 'mi_fixities' - , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint)) - -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that - -- the thing isn't in decls. It's useful to know that when seeing if we are - -- up to date wrt. the old interface. The 'OccName' is the parent of the - -- name, if it has one. - } - -data ModIfacePhase - = ModIfaceCore - -- ^ Partial interface built based on output of core pipeline. - | ModIfaceFinal - --- | Selects a IfaceDecl representation. --- For fully instantiated interfaces we also maintain --- a fingerprint, which is used for recompilation checks. -type family IfaceDeclExts (phase :: ModIfacePhase) where - IfaceDeclExts 'ModIfaceCore = IfaceDecl - IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) - -type family IfaceBackendExts (phase :: ModIfacePhase) where - IfaceBackendExts 'ModIfaceCore = () - IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend - - - -- | A 'ModIface' plus a 'ModDetails' summarises everything we know -- about a compiled module. The 'ModIface' is the stuff *before* linking, -- and can be written out to an interface file. The 'ModDetails is after @@ -977,11 +895,23 @@ type family IfaceBackendExts (phase :: ModIfacePhase) where -- except that we explicitly make the 'mi_decls' and a few other fields empty; -- as when reading we consolidate the declarations etc. into a number of indexed -- maps and environments in the 'ExternalPackageState'. -data ModIface_ (phase :: ModIfacePhase) +data ModIface = ModIface { mi_module :: !Module, -- ^ Name of the module we are for mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? - + mi_iface_hash :: !Fingerprint, -- ^ Hash of the whole interface + mi_mod_hash :: !Fingerprint, -- ^ Hash of the ABI only + mi_flag_hash :: !Fingerprint, -- ^ Hash of the important flags + -- used when compiling the module, + -- excluding optimisation flags + mi_opt_hash :: !Fingerprint, -- ^ Hash of optimisation flags + mi_hpc_hash :: !Fingerprint, -- ^ Hash of hpc flags + mi_plugin_hash :: !Fingerprint, -- ^ Hash of plugins + + mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans + mi_finsts :: !WhetherHasFamInst, + -- ^ Whether this module has family instances. + -- See Note [The type family instance consistency story]. mi_hsc_src :: !HscSource, -- ^ Boot? Signature? mi_deps :: Dependencies, @@ -1002,6 +932,8 @@ data ModIface_ (phase :: ModIfacePhase) -- Records the modules that are the declaration points for things -- exported by this module, and the 'OccName's of those things + mi_exp_hash :: !Fingerprint, + -- ^ Hash of export list mi_used_th :: !Bool, -- ^ Module required TH splices when it was compiled. @@ -1020,7 +952,7 @@ data ModIface_ (phase :: ModIfacePhase) -- NOT STRICT! we read this field lazily from the interface file - mi_decls :: [IfaceDeclExts phase], + mi_decls :: [(Fingerprint,IfaceDecl)], -- ^ Type, class and variable declarations -- The hash of an Id changes if its fixity or deprecations change -- (as well as its type of course) @@ -1046,6 +978,22 @@ data ModIface_ (phase :: ModIfacePhase) mi_insts :: [IfaceClsInst], -- ^ Sorted class instance mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances mi_rules :: [IfaceRule], -- ^ Sorted rules + mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules, class and family + -- instances combined + + -- Cached environments for easy lookup + -- These are computed (lazily) from other fields + -- and are not put into the interface file + mi_warn_fn :: OccName -> Maybe WarningTxt, + -- ^ Cached lookup for 'mi_warns' + mi_fix_fn :: OccName -> Maybe Fixity, + -- ^ Cached lookup for 'mi_fixities' + mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint), + -- ^ Cached lookup for 'mi_decls'. + -- The @Nothing@ in 'mi_hash_fn' means that the thing + -- isn't in decls. It's useful to know that when + -- seeing if we are up to date wrt. the old interface. + -- The 'OccName' is the parent of the name, if it has one. mi_hpc :: !AnyHpcUsage, -- ^ True if this program uses Hpc at any point in the program. @@ -1068,12 +1016,8 @@ data ModIface_ (phase :: ModIfacePhase) mi_decl_docs :: DeclDocMap, -- ^ Docs on declarations. - mi_arg_docs :: ArgDocMap, + mi_arg_docs :: ArgDocMap -- ^ Docs on arguments. - - mi_final_exts :: !(IfaceBackendExts phase) - -- ^ Either `()` or `ModIfaceBackend` for - -- a fully instantiated interface. } -- | Old-style accessor for whether or not the ModIface came from an hs-boot @@ -1084,12 +1028,12 @@ mi_boot iface = mi_hsc_src iface == HsBootFile -- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be -- found, 'defaultFixity' is returned instead. mi_fix :: ModIface -> OccName -> Fixity -mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity +mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity -- | The semantic module for this interface; e.g., if it's a interface -- for a signature, if 'mi_module' is @p[A=]:A@, 'mi_semantic_module' -- will be @@. -mi_semantic_module :: ModIface_ a -> Module +mi_semantic_module :: ModIface -> Module mi_semantic_module iface = case mi_sig_of iface of Nothing -> mi_module iface Just mod -> mod @@ -1129,34 +1073,33 @@ instance Binary ModIface where mi_hsc_src = hsc_src, mi_deps = deps, mi_usages = usages, - mi_exports = exports, mi_used_th = used_th, mi_fixities = fixities, mi_warns = warns, - mi_anns = anns, - mi_decls = decls, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, mi_hpc = hpc_info, mi_trust = trust, mi_trust_pkg = trust_pkg, - mi_complete_sigs = complete_sigs, mi_doc_hdr = doc_hdr, mi_decl_docs = decl_docs, mi_arg_docs = arg_docs, - mi_final_exts = ModIfaceBackend { - mi_iface_hash = iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_opt_hash = opt_hash, - mi_hpc_hash = hpc_hash, - mi_plugin_hash = plugin_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_exp_hash = exp_hash, - mi_orphan_hash = orphan_hash - }}) = do + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_exp_hash = exp_hash, + mi_orphan_hash = orphan_hash, + mi_exports = exports, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_anns = anns, + mi_complete_sigs = complete_sigs, + mi_decls = decls + }) = do put_ bh mod put_ bh sig_of put_ bh hsc_src @@ -1227,51 +1170,59 @@ instance Binary ModIface where mi_hsc_src = hsc_src, mi_deps = deps, mi_usages = usages, - mi_exports = exports, mi_used_th = used_th, - mi_anns = anns, mi_fixities = fixities, mi_warns = warns, - mi_decls = decls, mi_globals = Nothing, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, mi_hpc = hpc_info, mi_trust = trust, mi_trust_pkg = trust_pkg, -- And build the cached values - mi_complete_sigs = complete_sigs, mi_doc_hdr = doc_hdr, mi_decl_docs = decl_docs, mi_arg_docs = arg_docs, - mi_final_exts = ModIfaceBackend { - mi_iface_hash = iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_opt_hash = opt_hash, - mi_hpc_hash = hpc_hash, - mi_plugin_hash = plugin_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_exp_hash = exp_hash, - mi_orphan_hash = orphan_hash, - mi_warn_fn = mkIfaceWarnCache warns, - mi_fix_fn = mkIfaceFixCache fixities, - mi_hash_fn = mkIfaceHashCache decls - }}) + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_exp_hash = exp_hash, + mi_orphan_hash = orphan_hash, + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls, + mi_exports = exports, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_anns = anns, + mi_complete_sigs = complete_sigs, + mi_decls = decls + }) -- | The original names declared of a certain module that are exported type IfaceExport = AvailInfo -emptyPartialModIface :: Module -> PartialModIface -emptyPartialModIface mod +emptyModIface :: Module -> ModIface +emptyModIface mod = ModIface { mi_module = mod, mi_sig_of = Nothing, + mi_iface_hash = fingerprint0, + mi_mod_hash = fingerprint0, + mi_flag_hash = fingerprint0, + mi_opt_hash = fingerprint0, + mi_hpc_hash = fingerprint0, + mi_plugin_hash = fingerprint0, + mi_orphan = False, + mi_finsts = False, mi_hsc_src = HsSrcFile, mi_deps = noDependencies, mi_usages = [], mi_exports = [], + mi_exp_hash = fingerprint0, mi_used_th = False, mi_fixities = [], mi_warns = NoWarnings, @@ -1281,33 +1232,17 @@ emptyPartialModIface mod mi_rules = [], mi_decls = [], mi_globals = Nothing, + mi_orphan_hash = fingerprint0, + mi_warn_fn = emptyIfaceWarnCache, + mi_fix_fn = emptyIfaceFixCache, + mi_hash_fn = emptyIfaceHashCache, mi_hpc = False, mi_trust = noIfaceTrustInfo, mi_trust_pkg = False, mi_complete_sigs = [], mi_doc_hdr = Nothing, mi_decl_docs = emptyDeclDocMap, - mi_arg_docs = emptyArgDocMap, - mi_final_exts = () } - -emptyFullModIface :: Module -> ModIface -emptyFullModIface mod = - (emptyPartialModIface mod) - { mi_decls = [] - , mi_final_exts = ModIfaceBackend - { mi_iface_hash = fingerprint0, - mi_mod_hash = fingerprint0, - mi_flag_hash = fingerprint0, - mi_opt_hash = fingerprint0, - mi_hpc_hash = fingerprint0, - mi_plugin_hash = fingerprint0, - mi_orphan = False, - mi_finsts = False, - mi_exp_hash = fingerprint0, - mi_orphan_hash = fingerprint0, - mi_warn_fn = emptyIfaceWarnCache, - mi_fix_fn = emptyIfaceFixCache, - mi_hash_fn = emptyIfaceHashCache } } + mi_arg_docs = emptyArgDocMap } -- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] @@ -1440,6 +1375,57 @@ data ModGuts mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. } +-- | Like `ModGuts`, but only includes stuff we need for interface file +-- generation (see `MKIface.mkIface`). +data CgModGuts = CgModGuts + { cg_mg_module :: !Module + , cg_mg_hsc_src :: !HscSource + , cg_mg_usages :: ![Usage] + , cg_mg_used_th :: !Bool + , cg_mg_deps :: !Dependencies + , cg_mg_rdr_env :: !GlobalRdrEnv + , cg_mg_fix_env :: !FixityEnv + , cg_mg_warns :: !Warnings + , cg_mg_hpc_info :: !HpcInfo + , cg_mg_safe_haskell :: !SafeHaskellMode + , cg_mg_trust_pkg :: !Bool + , cg_mg_doc_hdr :: !(Maybe HsDocString) + , cg_mg_decl_docs :: !DeclDocMap + , cg_mg_arg_docs :: !ArgDocMap + , cg_mg_tcs :: ![TyCon] + , cg_mg_fam_insts :: ![FamInst] + , cg_mg_patsyns :: ![PatSyn] + , cg_mg_insts :: ![ClsInst] + , cg_mg_exports :: ![AvailInfo] + , cg_mg_anns :: ![Annotation] + , cg_mg_complete_sigs :: ![CompleteMatch] + } + +mkCgModGuts :: ModGuts -> CgModGuts +mkCgModGuts mod_guts = CgModGuts + { cg_mg_module = mg_module mod_guts + , cg_mg_hsc_src = mg_hsc_src mod_guts + , cg_mg_usages = mg_usages mod_guts + , cg_mg_used_th = mg_used_th mod_guts + , cg_mg_deps = mg_deps mod_guts + , cg_mg_rdr_env = mg_rdr_env mod_guts + , cg_mg_fix_env = mg_fix_env mod_guts + , cg_mg_warns = mg_warns mod_guts + , cg_mg_hpc_info = mg_hpc_info mod_guts + , cg_mg_safe_haskell = mg_safe_haskell mod_guts + , cg_mg_trust_pkg = mg_trust_pkg mod_guts + , cg_mg_doc_hdr = mg_doc_hdr mod_guts + , cg_mg_decl_docs = mg_decl_docs mod_guts + , cg_mg_arg_docs = mg_arg_docs mod_guts + , cg_mg_tcs = mg_tcs mod_guts + , cg_mg_fam_insts = mg_fam_insts mod_guts + , cg_mg_patsyns = mg_patsyns mod_guts + , cg_mg_insts = mg_insts mod_guts + , cg_mg_exports = mg_exports mod_guts + , cg_mg_anns = mg_anns mod_guts + , cg_mg_complete_sigs = mg_complete_sigs mod_guts + } + -- The ModGuts takes on several slightly different forms: -- -- After simplification, the following fields change slightly: @@ -1452,36 +1438,35 @@ data ModGuts -- and later compilations (ModDetails) -- * the other lot goes to code generation (CgGuts) --- | A restricted form of 'ModGuts' for code generation purposes -data CgGuts - = CgGuts { - cg_module :: !Module, - -- ^ Module being compiled - - cg_tycons :: [TyCon], - -- ^ Algebraic data types (including ones that started - -- life as classes); generate constructors and info - -- tables. Includes newtypes, just for the benefit of - -- External Core - - cg_binds :: CoreProgram, - -- ^ The tidied main bindings, including - -- previously-implicit bindings for record and class - -- selectors, and data constructor wrappers. But *not* - -- data constructor workers; reason: we regard them - -- as part of the code-gen of tycons - - cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs - cg_foreign_files :: ![(ForeignSrcLang, FilePath)], - cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to - -- generate #includes for C code gen - cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information - cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints - cg_spt_entries :: [SptEntry] - -- ^ Static pointer table entries for static forms defined in - -- the module. - -- See Note [Grand plan for static forms] in StaticPtrTable - } +data CgGuts = CgGuts + { cg_module :: !Module + -- ^ Module being compiled + , cg_tycons :: ![TyCon] + -- ^ Algebraic data types (including ones that started life as classes); + -- generate constructors and info tables. + , cg_binds :: !CoreProgram + -- ^ The tidied main bindings, including previously-implicit bindings for + -- record and class selectors, and data constructor wrappers. But *not* + -- data constructor workers; reason: we regard them as part of the code-gen + -- of tycons + , cg_foreign :: !ForeignStubs + -- ^ Foreign export stubs + , cg_foreign_files :: ![(ForeignSrcLang, FilePath)] + , cg_dep_pkgs :: ![InstalledUnitId] + -- ^ Dependent packages, used to generate #includes for C code gen + , cg_hpc_info :: !HpcInfo + -- ^ Program coverage tick box information + , cg_modBreaks :: !(Maybe ModBreaks) + -- ^ Module breakpoints + , cg_spt_entries :: ![SptEntry] + -- ^ Static pointer table entries for static forms defined in the module. + -- See Note [Grand plan for static forms] in StaticPtrTable + + -- Pre-tidied stuff for ModDetails generation + , cg_tidy_binds :: !CoreProgram + , cg_trimmed_rules :: ![CoreRule] + , cg_tidy_env :: !TidyEnv + } ----------------------------------- -- | Foreign export stubs @@ -3248,14 +3233,3 @@ phaseForeignLanguage phase = case phase of Phase.As _ -> Just LangAsm Phase.MergeForeign -> Just RawObject _ -> Nothing - -------------------------------------------- - --- Take care, this instance only forces to the degree necessary to --- avoid major space leaks. -instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where - rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 - f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) = - rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` - f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` - rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 47e89560b2c891bfdad104471d05efd0de440344..4969e78ce1d153d293939dacd2f22c711b300408 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -7,7 +7,9 @@ {-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-} module TidyPgm ( - mkBootModDetailsTc, tidyProgram + mkBootModDetailsTc, tidyProgram, + -- * Stuff for ModDetails generation + mkFinalPatSyns, mkFinalClsInsts, extendTypeEnvWithPatSyns ) where #include "HsVersions.h" @@ -27,7 +29,6 @@ import CoreStats (coreBindsStats, CoreStats(..)) import CoreSeq (seqBinds) import CoreLint import Literal -import Rules import PatSyn import ConLike import CoreArity ( exprArity, exprBotStrictness_maybe ) @@ -58,10 +59,11 @@ import HscTypes import Maybes import UniqSupply import Outputable -import Util( filterOut ) +import Util( filterOut, seqListId ) import qualified ErrUtils as Err import Control.Monad +import Control.DeepSeq import Data.Function import Data.List ( sortBy, mapAccumL ) import Data.IORef ( atomicModifyIORef' ) @@ -93,7 +95,7 @@ of TyThings. Plan A: mkBootModDetails: omit pragmas, make interfaces small -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Ignore the bindings * Drop all WiredIn things from the TypeEnv @@ -229,7 +231,7 @@ globaliseAndTidyBootId id ************************************************************************ Plan B: include pragmas, make interfaces -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Step 1: Figure out which Ids are externally visible See Note [Choosing external Ids] @@ -322,143 +324,82 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. -} -tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) -tidyProgram hsc_env (ModGuts { mg_module = mod - , mg_exports = exports - , mg_rdr_env = rdr_env - , mg_tcs = tcs - , mg_insts = cls_insts - , mg_fam_insts = fam_insts - , mg_binds = binds - , mg_patsyns = patsyns - , mg_rules = imp_rules - , mg_anns = anns - , mg_complete_sigs = complete_sigs - , mg_deps = deps - , mg_foreign = foreign_stubs - , mg_foreign_files = foreign_files - , mg_hpc_info = hpc_info - , mg_modBreaks = modBreaks - }) - - = Err.withTiming dflags - (text "CoreTidy"<+>brackets (ppr mod)) - (const ()) $ - do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags - ; expose_all = gopt Opt_ExposeAllUnfoldings dflags - ; print_unqual = mkPrintUnqualified dflags rdr_env - ; implicit_binds = concatMap getImplicitBinds tcs - } - - ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags expose_all - binds implicit_binds imp_rules - ; let { (trimmed_binds, trimmed_rules) - = findExternalRules omit_prags binds imp_rules unfold_env } - - ; (tidy_env, tidy_binds) - <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds - - -- See Note [Grand plan for static forms] in StaticPtrTable. - ; (spt_entries, tidy_binds') <- - sptCreateStaticBinds hsc_env mod tidy_binds - ; let { spt_init_code = sptModuleInitCode mod spt_entries - ; add_spt_init_code = - case hscTarget dflags of - -- If we are compiling for the interpreter we will insert - -- any necessary SPT entries dynamically - HscInterpreted -> id - -- otherwise add a C stub to do so - _ -> (`appendStubC` spt_init_code) - - -- The completed type environment is gotten from - -- a) the types and classes defined here (plus implicit things) - -- b) adding Ids with correct IdInfo, including unfoldings, - -- gotten from the bindings - -- From (b) we keep only those Ids with External names; - -- the CoreTidy pass makes sure these are all and only - -- the externally-accessible ones - -- This truncates the type environment to include only the - -- exported Ids and things needed from them, which saves space - -- - -- See Note [Don't attempt to trim data types] - ; final_ids = [ if omit_prags then trimId id else id - | id <- bindersOfBinds tidy_binds - , isExternalName (idName id) - , not (isWiredIn id) - ] -- See Note [Drop wired-in things] - - ; final_tcs = filterOut isWiredIn tcs - -- See Note [Drop wired-in things] - ; type_env = typeEnvFromEntities final_ids final_tcs fam_insts - ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts - ; tidy_patsyns = mkFinalPatSyns type_env patsyns - ; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env - ; tidy_rules = tidyRules tidy_env trimmed_rules - - ; -- See Note [Injecting implicit bindings] - all_tidy_binds = implicit_binds ++ tidy_binds' - - -- Get the TyCons to generate code for. Careful! We must use - -- the untidied TyCons here, because we need - -- (a) implicit TyCons arising from types and classes defined - -- in this module - -- (b) wired-in TyCons, which are normally removed from the - -- TypeEnv we put in the ModDetails - -- (c) Constructors even if they are not exported (the - -- tidied TypeEnv has trimmed these away) - ; alg_tycons = filter isAlgTyCon tcs - } - - ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules - - -- If the endPass didn't print the rules, but ddump-rules is - -- on, print now - ; unless (dopt Opt_D_dump_simpl dflags) $ - Err.dumpIfSet_dyn dflags Opt_D_dump_rules - (showSDoc dflags (ppr CoreTidy <+> text "rules")) - Err.FormatText - (pprRulesForUser dflags tidy_rules) - - -- Print one-line size info - ; let cs = coreBindsStats tidy_binds - ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats" +tidyProgram :: HscEnv -> ModGuts -> IO CgGuts +tidyProgram hsc_env mod_guts = + Err.withTiming (hsc_dflags hsc_env) (text "CoreTidy" <+> brackets (ppr (mg_module mod_guts))) (const ()) $ do + let ModGuts { mg_module = mod + , mg_tcs = tcs + , mg_foreign = foreign_stubs + , mg_foreign_files = foreign_files + , mg_deps = deps + , mg_hpc_info = hpc_info + , mg_modBreaks = mod_breaks + , mg_binds = binds + , mg_rules = rules + , mg_rdr_env = rdr_env + } = mod_guts + + let dflags = hsc_dflags hsc_env + let omit_prags = gopt Opt_OmitInterfacePragmas dflags + let expose_all = gopt Opt_ExposeAllUnfoldings dflags + let implicit_binds = concatMap getImplicitBinds tcs + + (unfold_env, tidy_occ_env) + <- chooseExternalIds hsc_env mod omit_prags expose_all + binds implicit_binds rules + + let (trimmed_binds, trimmed_rules) = findExternalRules omit_prags binds rules unfold_env + + (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds + + -- See Note [Grand plan for static forms] in StaticPtrTable. + (spt_entries, tidy_binds') <- + sptCreateStaticBinds hsc_env (mg_module mod_guts) tidy_binds + + -- See Note [Injecting implicit bindings] + let implicit_binds = concatMap getImplicitBinds tcs + let all_tidy_binds = implicit_binds ++ tidy_binds' + + let spt_init_code = sptModuleInitCode mod spt_entries + add_spt_init_code = + case hscTarget dflags of + -- If we are compiling for the interpreter we will insert + -- any necessary SPT entries dynamically + HscInterpreted -> id + -- otherwise add a C stub to do so + _ -> (`appendStubC` spt_init_code) + + + let print_unqual = mkPrintUnqualified dflags rdr_env + -- TODO (osa): We can't dump rules here as we tidy them later (after code + -- gen). Is this going to be a problem? + -- Rules are dumped in mkFullIface + endPassIO hsc_env print_unqual CoreTidy all_tidy_binds [] + + -- Print one-line size info + let cs = coreBindsStats tidy_binds + Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats" Err.FormatText (text "Tidy size (terms,types,coercions)" <+> ppr (moduleName mod) <> colon <+> int (cs_tm cs) <+> int (cs_ty cs) - <+> int (cs_co cs) ) - - ; return (CgGuts { cg_module = mod, - cg_tycons = alg_tycons, - cg_binds = all_tidy_binds, - cg_foreign = add_spt_init_code foreign_stubs, - cg_foreign_files = foreign_files, - cg_dep_pkgs = map fst $ dep_pkgs deps, - cg_hpc_info = hpc_info, - cg_modBreaks = modBreaks, - cg_spt_entries = spt_entries }, - - ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_cls_insts, - md_fam_insts = fam_insts, - md_exports = exports, - md_anns = anns, -- are already tidy - md_complete_sigs = complete_sigs - }) - } - where - dflags = hsc_dflags hsc_env - --------------------------- -trimId :: Id -> Id -trimId id - | not (isImplicitId id) - = id `setIdInfo` vanillaIdInfo - | otherwise - = id + <+> int (cs_co cs)) + + return $! CgGuts + { cg_module = force mod + , cg_tycons = seqListId (filter isAlgTyCon tcs) + , cg_binds = seqListId all_tidy_binds + , cg_foreign = add_spt_init_code foreign_stubs + , cg_foreign_files = seqListId foreign_files + , cg_dep_pkgs = seqListId (map fst (dep_pkgs deps)) + , cg_hpc_info = hpc_info + , cg_modBreaks = mod_breaks + , cg_spt_entries = spt_entries + , cg_tidy_binds = seqListId tidy_binds + , cg_trimmed_rules = seqListId trimmed_rules + , cg_tidy_env = tidy_env + } {- Note [Drop wired-in things] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 6f615a1721327c74e1b2e91b15bb0b1fa4766f52..f5f2def25d396d809107fa27f05d667455c14d78 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1266,10 +1266,10 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt lookupImpDeprec iface gre - = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, + = mi_warn_fn iface (greOccName gre) `mplus` -- Bleat if the thing, case gre_par gre of -- or its parent, is warn'd - ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p) - FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p) + ParentIs p -> mi_warn_fn iface (nameOccName p) + FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p) NoParent -> Nothing {- diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs index 68d13488711d5dbbd9152cb1cdeb42c13aea335b..198a0441e5baa768a485ebf7bb9940b27e5c94dd 100644 --- a/compiler/rename/RnFixity.hs +++ b/compiler/rename/RnFixity.hs @@ -157,7 +157,7 @@ lookupFixityRn_help' name occ -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. = do { iface <- loadInterfaceForName doc name - ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ + ; let mb_fix = mi_fix_fn iface occ ; let msg = case mb_fix of Nothing -> text "looking up name" <+> ppr name diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 7614fb19328b4ff5aa4d7edf42703ae260675675..70c4207455bd60ee64b43537c4af6fac12a517e0 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -394,8 +394,8 @@ calculateAvails :: DynFlags calculateAvails dflags iface mod_safe' want_boot imported_by = let imp_mod = mi_module iface imp_sem_mod= mi_semantic_module iface - orph_iface = mi_orphan (mi_final_exts iface) - has_finsts = mi_finsts (mi_final_exts iface) + orph_iface = mi_orphan iface + has_finsts = mi_finsts iface deps = mi_deps iface trust = getSafeMode $ mi_trust iface trust_pkg = mi_trust_pkg iface diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 36c613c18684e85a3af00b632a1ffd455e0a41b4..5e755e54318262e35abf5d08a9ae5944c6f872e5 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -322,7 +322,7 @@ checkFamInstConsistency directlyImpMods -- Note [Checking family instance optimization] ; modConsistent :: Module -> [Module] ; modConsistent mod = - if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps + if mi_finsts (modIface mod) then mod:deps else deps where deps = dep_finsts . mi_deps . modIface $ mod diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index fccc373368cbc457b82bdfbcf1f9ace612ca0d8f..d7cc0409fd3231b8cf4804090f27618b481e8c5a 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -93,7 +93,7 @@ checkHsigDeclM sig_iface sig_thing real_thing = do -- implementation cases. checkBootDeclM False sig_thing real_thing real_fixity <- lookupFixityRn name - let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of + let sig_fixity = case mi_fix_fn sig_iface (occName name) of Nothing -> defaultFixity Just f -> f when (real_fixity /= sig_fixity) $ @@ -833,7 +833,7 @@ mergeSignatures -- This is a HACK to prevent calculateAvails from including imp_mod -- in the listing. We don't want it because a module is NOT -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 - iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } + iface' = iface { mi_orphan = False, mi_finsts = False } avails = plusImportAvails (tcg_imports tcg_env) $ calculateAvails dflags iface' False False ImportedBySystem return tcg_env { @@ -844,7 +844,7 @@ mergeSignatures if outer_mod == mi_module iface -- Don't add ourselves! then tcg_merged tcg_env - else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env + else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env } -- Note [Signature merging DFuns] diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs index 0e8f0a6d06af838bff549f08d2e9bb906a70cf4a..971d55371a2f5d91a7ab16e9275b476c08a8600e 100644 --- a/compiler/typecheck/TcHoleErrors.hs +++ b/compiler/typecheck/TcHoleErrors.hs @@ -53,7 +53,7 @@ import TcUnify ( tcSubType_NC ) import ExtractDocs ( extractDocs ) import qualified Data.Map as Map import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) -import HscTypes ( ModIface_(..) ) +import HscTypes ( ModIface(..) ) import LoadIface ( loadInterfaceForNameMaybe ) import PrelInfo (knownKeyNames) diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index e8d20e320808d108f306d63879c1e76643ed6e65..1ddacd3819baf818438986e927246cf90afc0f41 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -78,7 +78,7 @@ module Util ( transitiveClosure, -- * Strictness - seqList, + seqList, seqListId, -- * Module names looksLikeModuleName, @@ -1006,6 +1006,8 @@ seqList :: [a] -> b -> b seqList [] b = b seqList (x:xs) b = x `seq` seqList xs b +seqListId :: [a] -> [a] +seqListId lst = seqList lst lst {- ************************************************************************ diff --git a/ghc/Main.hs b/ghc/Main.hs index b66f567d2f5e35f149d52a78191d26840fc4cc56..f625ae3768008c308482582b91b34be5816d91b9 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -924,7 +924,7 @@ abiHash strs = do put_ bh hiVersion -- package hashes change when the compiler version changes (for now) -- see #5328 - mapM_ (put_ bh . mi_mod_hash . mi_final_exts) ifaces + mapM_ (put_ bh . mi_mod_hash) ifaces f <- fingerprintBinMem bh putStrLn (showPpr dflags f) diff --git a/testsuite/tests/driver/Makefile b/testsuite/tests/driver/Makefile index d1bb30ff37826a85e28ff7efe8e4cd5338e6650a..19c18c525f8dd3d782b0af58b93c877883293fea 100644 --- a/testsuite/tests/driver/Makefile +++ b/testsuite/tests/driver/Makefile @@ -519,13 +519,6 @@ T5198: "$(TEST_HC)" $(TEST_HC_OPTS) -c T5198.hs -dumpdir T5198dump -ddump-to-file -ddump-simpl [ -f T5198dump/T5198.dump-simpl ] -.PHONY: T7060a -T7060a: - $(RM) -rf T7060dump - [ ! -d T7060dump ] - "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T7060.hs -dumpdir T7060dump -ddump-to-file -ddump-rules - [ -f T7060dump/T7060.dump-rules ] - .PHONY: T7060b T7060b: $(RM) -rf T7060dump @@ -541,7 +534,7 @@ T7060c: [ -f T7060dump/T7060.dump-rule-rewrites ] .PHONY: T7060 -T7060: T7060a T7060b T7060c +T7060: T7060b T7060c .PHONY: T7130 T7130: diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index 0d7e44b4b66a15c30cf54e842404c27f44df5e98..075026450cbb4b2fe9eb2917156d1d255964182e 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -59,10 +59,9 @@ metaPlugin' [name, "meta"] (L _ (HsApp noExt (L l (HsVar _ (L _ id))) e)) metaPlugin' _ meta = return meta interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface -interfaceLoadPlugin' [name, "interface"] iface - = return $ iface { mi_exports = filter (availNotNamedAs name) - (mi_exports iface) - } +interfaceLoadPlugin' [name, "interface"] iface = do + let exports = mi_exports iface + return iface{ mi_exports = filter (availNotNamedAs name) exports } interfaceLoadPlugin' _ iface = return iface availNotNamedAs :: String -> AvailInfo -> Bool diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index 62f300e962a248854441a321db12763f74e4be4f..b790f6e516817eb170f5c35226f3fc691d5a2b92 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -105,9 +105,13 @@ f = \ (w :: Int) (w1 :: (Int, Int)) -> case w of { I# ww1 -> T4908.$wf ww1 w1 } ------- Local rules for imported ids -------- + + +==================== Tidy Rules ==================== "SC:$wf0" [2] - forall (sc :: Int) (sc1 :: Int#) (sc2 :: Int#). + forall (sc :: GHC.Types.Int) + (sc1 :: GHC.Prim.Int#) + (sc2 :: GHC.Prim.Int#). T4908.$wf sc2 (sc, GHC.Types.I# sc1) = T4908.f_$s$wf sc sc1 sc2 diff --git a/testsuite/tests/simplCore/should_compile/T5776.stdout b/testsuite/tests/simplCore/should_compile/T5776.stdout index 00750edc07d6415dcc07ae0351e9397b0222b7ba..b8626c4cff2849624fb67f87cd0ad72b163671ad 100644 --- a/testsuite/tests/simplCore/should_compile/T5776.stdout +++ b/testsuite/tests/simplCore/should_compile/T5776.stdout @@ -1 +1 @@ -3 +4 diff --git a/testsuite/tests/simplCore/should_compile/T7785.stderr b/testsuite/tests/simplCore/should_compile/T7785.stderr index 3fd78bd67fa9e036fa35140b0a15b8fec0e33cae..98fe426863d6d88bb1084e280ae88cd18fc5c306 100644 --- a/testsuite/tests/simplCore/should_compile/T7785.stderr +++ b/testsuite/tests/simplCore/should_compile/T7785.stderr @@ -1,8 +1,9 @@ -==================== Tidy Core rules ==================== +==================== Tidy Rules ==================== "SPEC shared @ []" - forall ($dMyFunctor :: MyFunctor []) (irred :: Domain [] Int). - shared @ [] $dMyFunctor irred - = bar_$sshared + forall ($dMyFunctor :: Foo.MyFunctor []) + (irred :: Foo.Domain [] GHC.Types.Int). + Foo.shared @ [] $dMyFunctor irred + = Foo.bar_$sshared diff --git a/testsuite/tests/simplCore/should_compile/T8331.stderr b/testsuite/tests/simplCore/should_compile/T8331.stderr index 322323be6cf4a735ee2f1d9cda234c5fa74ed87f..7bbd4548cce39f89b6bec6fe9d4d5cb2d75d926a 100644 --- a/testsuite/tests/simplCore/should_compile/T8331.stderr +++ b/testsuite/tests/simplCore/should_compile/T8331.stderr @@ -1,9 +1,12 @@ -==================== Tidy Core rules ==================== +==================== Tidy Rules ==================== "SPEC useAbstractMonad" forall (@ s) - ($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))). - useAbstractMonad @ (ReaderT Int (ST s)) $dMonadAbstractIOST - = useAbstractMonad_$suseAbstractMonad @ s + ($dMonadAbstractIOST + :: Main.MonadAbstractIOST + (Main.ReaderT GHC.Types.Int (GHC.ST.ST s))). + Main.useAbstractMonad @ (Main.ReaderT GHC.Types.Int (GHC.ST.ST s)) + $dMonadAbstractIOST + = Main.useAbstractMonad_$suseAbstractMonad @ s diff --git a/testsuite/tests/simplCore/should_compile/T8848a.stderr b/testsuite/tests/simplCore/should_compile/T8848a.stderr index f6f8b4f247682667097f95d50df4d8216718596c..bed395cc195b46e1788e9c12ff88f2db1b670d78 100644 --- a/testsuite/tests/simplCore/should_compile/T8848a.stderr +++ b/testsuite/tests/simplCore/should_compile/T8848a.stderr @@ -1,6 +1,8 @@ -==================== Tidy Core rules ==================== +==================== Tidy Rules ==================== "SPEC f" - forall (@ b) ($dOrd :: Ord [Int]). f @ [Int] @ b $dOrd = f_$sf @ b + forall (@ b) ($dOrd :: GHC.Classes.Ord [GHC.Types.Int]). + T8848a.f @ [GHC.Types.Int] @ b $dOrd + = T8848a.f_$sf @ b diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 7146b76e6d63ed5f68c4d29af9a375be58a18bd8..2f6f3b94871271c939218dbeffc0649c6ecd10a4 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -135,7 +135,7 @@ test('T5366', test('T7796', [], makefile_test, ['T7796']) test('T5550', omit_ways(prof_ways), compile, ['']) test('T7865', normal, makefile_test, ['T7865']) -test('T7785', only_ways(['optasm']), compile, ['-ddump-rules']) +test('T7785', only_ways(['optasm']), compile, ['-ddump-rules -dsuppress-uniques']) test('T7702', [extra_files(['T7702plugin']), only_ways([config.ghc_plugin_way]), @@ -175,8 +175,8 @@ test('T8832', ('-DT8832_WORDSIZE_64' if wordsize(64) else '')]) test('T8848', normal, makefile_test, ['T8848']) -test('T8848a', only_ways(['optasm']), compile, ['-ddump-rules']) -test('T8331', only_ways(['optasm']), compile, ['-ddump-rules']) +test('T8848a', only_ways(['optasm']), compile, ['-ddump-rules -dsuppress-uniques']) +test('T8331', only_ways(['optasm']), compile, ['-ddump-rules -dsuppress-uniques']) test('T6056', only_ways(['optasm']), multimod_compile, ['T6056', '-v0 -ddump-rule-firings']) test('T9400', only_ways(['optasm']), compile, ['-O0 -ddump-simpl -dsuppress-uniques -dsuppress-ticks']) test('T9441a', [only_ways(['optasm']), check_errmsg(r'f1 = f2') ], compile, ['-ddump-simpl -dsuppress-ticks']) diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 07b04c215edd0228bbf0e2e305b448f3300c21b6..551cb4037c39230a6bf2f2add406b251d8c09c3e 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -171,11 +171,13 @@ foo } ------- Local rules for imported ids -------- + + +==================== Tidy Rules ==================== "SC:$wgo0" [2] forall (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#). - Roman.$wgo (GHC.Maybe.Just @ Int (GHC.Types.I# sc1)) - (GHC.Maybe.Just @ Int (GHC.Types.I# sc)) + Roman.$wgo (GHC.Maybe.Just @ GHC.Types.Int (GHC.Types.I# sc1)) + (GHC.Maybe.Just @ GHC.Types.Int (GHC.Types.I# sc)) = Roman.foo_$s$wgo sc sc1 diff --git a/testsuite/tests/simplCore/should_run/T2486.stderr b/testsuite/tests/simplCore/should_run/T2486.stderr deleted file mode 100644 index 079367fbeea28e044178479da7948a5c983851f3..0000000000000000000000000000000000000000 --- a/testsuite/tests/simplCore/should_run/T2486.stderr +++ /dev/null @@ -1,4 +0,0 @@ - -==================== Tidy Core rules ==================== - -