diff options
Diffstat (limited to 'compiler/deSugar/Desugar.hs')
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 201 |
1 files changed, 195 insertions, 6 deletions
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index dceebc1fcd..77834e0160 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -8,14 +8,20 @@ The Desugarer: turning HsSyn into Core. {-# LANGUAGE CPP #-} -module Desugar ( deSugar, deSugarExpr ) where +module Desugar ( + -- * Desugaring operations + deSugar, deSugarExpr, + -- * Dependency/fingerprinting code (used by MkIface) + mkUsageInfo, mkUsedNames, mkDependencies + ) where + +#include "HsVersions.h" import DynFlags import HscTypes import HsSyn import TcRnTypes import TcRnMonad ( finalSafeMode, fixSafeInstances ) -import MkIface import Id import Name import Type @@ -52,9 +58,193 @@ import Util import MonadUtils import OrdList import StaticPtrTable +import UniqFM +import ListSetOps +import Fingerprint +import Maybes + +import Data.Function import Data.List import Data.IORef import Control.Monad( when ) +import Data.Map (Map) +import qualified Data.Map as Map + +-- | Extract information from the rename and typecheck phases to produce +-- a dependencies information for the module being compiled. +mkDependencies :: TcGblEnv -> IO Dependencies +mkDependencies + TcGblEnv{ tcg_mod = mod, + tcg_imports = imports, + tcg_th_used = th_var + } + = do + -- Template Haskell used? + th_used <- readIORef th_var + let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) + -- M.hi-boot can be in the imp_dep_mods, but we must remove + -- it before recording the modules on which this one depends! + -- (We want to retain M.hi-boot in imp_dep_mods so that + -- loadHiBootInterface can see if M's direct imports depend + -- on M.hi-boot, and hence that we should do the hi-boot consistency + -- check.) + + pkgs | th_used = insertList thUnitId (imp_dep_pkgs imports) + | otherwise = imp_dep_pkgs imports + + -- Set the packages required to be Safe according to Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] + sorted_pkgs = sortBy stableUnitIdCmp pkgs + trust_pkgs = imp_trust_pkgs imports + dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs + + return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods, + dep_pkgs = dep_pkgs', + dep_orphs = sortBy stableModuleCmp (imp_orphs imports), + dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } + -- sort to get into canonical order + -- NB. remember to use lexicographic ordering + +mkUsedNames :: TcGblEnv -> NameSet +mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus + +mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage] +mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files + = do + eps <- hscEPS hsc_env + hashes <- mapM getFileHash dependent_files + let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod + dir_imp_mods used_names + let usages = mod_usages ++ [ UsageFile { usg_file_path = f + , usg_file_hash = hash } + | (f, hash) <- zip dependent_files hashes ] + usages `seqList` return usages + -- seq the list of Usages returned: occasionally these + -- don't get evaluated for a while and we can end up hanging on to + -- the entire collection of Ifaces. + +mk_mod_usage_info :: PackageIfaceTable + -> HscEnv + -> Module + -> ImportedMods + -> NameSet + -> [Usage] +mk_mod_usage_info pit hsc_env this_mod direct_imports used_names + = mapMaybe mkUsage usage_mods + where + hpt = hsc_HPT hsc_env + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + + used_mods = moduleEnvKeys ent_map + dir_imp_mods = moduleEnvKeys direct_imports + all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods + usage_mods = sortBy stableModuleCmp all_mods + -- canonical order is imported, to avoid interface-file + -- wobblage. + + -- ent_map groups together all the things imported and used + -- from a particular module + ent_map :: ModuleEnv [OccName] + ent_map = foldNameSet add_mv emptyModuleEnv used_names + where + add_mv name mv_map + | isWiredInName name = mv_map -- ignore wired-in names + | otherwise + = case nameModule_maybe name of + Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map + -- See Note [Internal used_names] + + Just mod -> -- This lambda function is really just a + -- specialised (++); originally came about to + -- avoid quadratic behaviour (trac #2680) + extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ] + where occ = nameOccName name + + -- We want to create a Usage for a home module if + -- a) we used something from it; has something in used_names + -- b) we imported it, even if we used nothing from it + -- (need to recompile if its export list changes: export_fprint) + mkUsage :: Module -> Maybe Usage + mkUsage mod + | isNothing maybe_iface -- We can't depend on it if we didn't + -- load its interface. + || mod == this_mod -- We don't care about usages of + -- things in *this* module + = Nothing + + | moduleUnitId mod /= this_pkg + = Just UsagePackageModule{ usg_mod = mod, + usg_mod_hash = mod_hash, + usg_safe = imp_safe } + -- for package modules, we record the module hash only + + | (null used_occs + && isNothing export_hash + && not is_direct_import + && not finsts_mod) + = Nothing -- Record no usage info + -- for directly-imported modules, we always want to record a usage + -- on the orphan hash. This is what triggers a recompilation if + -- an orphan is added or removed somewhere below us in the future. + + | otherwise + = Just UsageHomeModule { + usg_mod_name = moduleName mod, + usg_mod_hash = mod_hash, + usg_exports = export_hash, + usg_entities = Map.toList ent_hashs, + usg_safe = imp_safe } + where + maybe_iface = lookupIfaceByModule dflags hpt pit mod + -- In one-shot mode, the interfaces for home-package + -- modules accumulate in the PIT not HPT. Sigh. + + Just iface = maybe_iface + finsts_mod = mi_finsts iface + hash_env = mi_hash_fn iface + mod_hash = mi_mod_hash iface + export_hash | depend_on_exports = Just (mi_exp_hash iface) + | otherwise = Nothing + + (is_direct_import, imp_safe) + = case lookupModuleEnv direct_imports mod of + Just (imv : _xs) -> (True, imv_is_safe imv) + Just _ -> pprPanic "mkUsage: empty direct import" Outputable.empty + Nothing -> (False, safeImplicitImpsReq dflags) + -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn' + -- is used in the source code. We require them to be safe in Safe Haskell + + used_occs = lookupModuleEnv ent_map mod `orElse` [] + + -- Making a Map here ensures that (a) we remove duplicates + -- when we have usages on several subordinates of a single parent, + -- and (b) that the usages emerge in a canonical order, which + -- is why we use Map rather than OccEnv: Map works + -- using Ord on the OccNames, which is a lexicographic ordering. + ent_hashs :: Map OccName Fingerprint + ent_hashs = Map.fromList (map lookup_occ used_occs) + + lookup_occ occ = + case hash_env occ of + Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) + Just r -> r + + depend_on_exports = is_direct_import + {- True + Even if we used 'import M ()', we have to register a + usage on the export list because we are sensitive to + changes in orphan instances/rules. + False + In GHC 6.8.x we always returned true, and in + fact it recorded a dependency on *all* the + modules underneath in the dependency tree. This + happens to make orphans work right, but is too + expensive: it'll read too many interface files. + The 'isNothing maybe_iface' check above saved us + from generating many of these usages (at least in + one-shot mode), but that's even more bogus! + -} {- ************************************************************************ @@ -167,16 +357,16 @@ deSugar hsc_env ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files ; safe_mode <- finalSafeMode dflags tcg_env + ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files ; let mod_guts = ModGuts { mg_module = mod, mg_hsc_src = hsc_src, mg_loc = mkFileSrcSpan mod_loc, mg_exports = exports, + mg_usages = usages, mg_deps = deps, - mg_used_names = used_names, mg_used_th = used_th, - mg_dir_imps = imp_mods imports, mg_rdr_env = rdr_env, mg_fix_env = fix_env, mg_warns = warns, @@ -195,8 +385,7 @@ deSugar hsc_env mg_vect_decls = ds_vects, mg_vect_info = noVectInfo, mg_safe_haskell = safe_mode, - mg_trust_pkg = imp_trust_own_pkg imports, - mg_dependent_files = dep_files + mg_trust_pkg = imp_trust_own_pkg imports } ; return (msgs, Just mod_guts) }}} |