diff options
author | Reid Barton <rwbarton@gmail.com> | 2017-02-14 13:13:56 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-02-14 16:57:31 -0500 |
commit | f90e61ad6e5fa0655185f14ca128d507e489c4b7 (patch) | |
tree | e2300077b28f422c0918cb3fdbb50d45464c5a8f | |
parent | bedcb71659253bb8ab5d449df8e3ee884cc85d46 (diff) | |
download | haskell-f90e61ad6e5fa0655185f14ca128d507e489c4b7.tar.gz |
Make deSugarExpr use runTcInteractive
Preparation for #13102, which needs to add more logic to
runTcInteractive, which would need to be duplicated in deSugarExpr.
In order to break an import cycle, I had to move
"Dependency/fingerprinting code" to a new module
DsUsage; which seems sensible anyways.
Test Plan: validate
Reviewers: simonpj, austin, bgamari
Reviewed By: bgamari
Subscribers: thomie, snowleopard
Differential Revision: https://phabricator.haskell.org/D3125
-rw-r--r-- | compiler/deSugar/Desugar.hs | 214 | ||||
-rw-r--r-- | compiler/deSugar/DsUsage.hs | 211 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
-rw-r--r-- | compiler/iface/MkIface.hs | 2 |
4 files changed, 221 insertions, 207 deletions
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 5111141770..d5931d16e5 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -10,22 +10,21 @@ The Desugarer: turning HsSyn into Core. module Desugar ( -- * Desugaring operations - deSugar, deSugarExpr, - -- * Dependency/fingerprinting code (used by MkIface) - mkUsageInfo, mkUsedNames, mkDependencies + deSugar, deSugarExpr ) where #include "HsVersions.h" +import DsUsage import DynFlags import HscTypes import HsSyn import TcRnTypes import TcRnMonad ( finalSafeMode, fixSafeInstances ) +import TcRnDriver ( runTcInteractive ) import Id import Name import Type -import FamInstEnv import InstEnv import Class import Avail @@ -60,201 +59,10 @@ import Coverage import Util import MonadUtils import OrdList -import UniqFM -import UniqDFM -import ListSetOps -import Fingerprint -import Maybes 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 = eltsUDFM (delFromUDFM (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 (toInstalledUnitId 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 = sort pkgs - trust_pkgs = imp_trust_pkgs imports - dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs - - return Deps { dep_mods = 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] -> [(Module, Fingerprint)] -> IO [Usage] -mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged - = 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 - usages = mod_usages ++ [ UsageFile { usg_file_path = f - , usg_file_hash = hash } - | (f, hash) <- zip dependent_files hashes ] - ++ [ UsageMergedRequirement - { usg_mod = mod, - usg_mod_hash = hash - } - | (mod, hash) <- merged ] - 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 = nonDetFoldUFM add_mv emptyModuleEnv used_names - -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName - -- in ent_hashs - 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! - -} {- ************************************************************************ @@ -446,25 +254,19 @@ and Rec the rest. deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr) -deSugarExpr hsc_env tc_expr - = do { let dflags = hsc_dflags hsc_env - icntxt = hsc_IC hsc_env - rdr_env = ic_rn_gbl_env icntxt - type_env = mkTypeEnvWithImplicits (ic_tythings icntxt) - fam_insts = snd (ic_instances icntxt) - fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts - -- This stuff is a half baked version of TcRnDriver.setInteractiveContext +deSugarExpr hsc_env tc_expr = do { + let dflags = hsc_dflags hsc_env ; showPass dflags "Desugar" -- Do desugaring - ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env - type_env fam_inst_env [] $ + ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ dsLExpr tc_expr ; case mb_core_expr of Nothing -> return () - Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr) + Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" + (pprCoreExpr expr) ; return (msgs, mb_core_expr) } diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs new file mode 100644 index 0000000000..665f2933bb --- /dev/null +++ b/compiler/deSugar/DsUsage.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE CPP #-} + +module DsUsage ( + -- * Dependency/fingerprinting code (used by MkIface) + mkUsageInfo, mkUsedNames, mkDependencies + ) where + +#include "HsVersions.h" + +import DynFlags +import HscTypes +import TcRnTypes +import Name +import NameSet +import Module +import Outputable +import Util +import UniqFM +import UniqDFM +import ListSetOps +import Fingerprint +import Maybes + +import Data.List +import Data.IORef +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 = eltsUDFM (delFromUDFM (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 (toInstalledUnitId 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 = sort pkgs + trust_pkgs = imp_trust_pkgs imports + dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs + + return Deps { dep_mods = 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] -> [(Module, Fingerprint)] -> IO [Usage] +mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged + = 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 + usages = mod_usages ++ [ UsageFile { usg_file_path = f + , usg_file_hash = hash } + | (f, hash) <- zip dependent_files hashes ] + ++ [ UsageMergedRequirement + { usg_mod = mod, + usg_mod_hash = hash + } + | (mod, hash) <- merged ] + 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 = nonDetFoldUFM add_mv emptyModuleEnv used_names + -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName + -- in ent_hashs + 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! + -} diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 0d1a45b56b..f3d6711f89 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -298,6 +298,7 @@ Library DsGRHSs DsListComp DsMonad + DsUsage DsUtils Match MatchCon diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 5215965aa4..aacdac9b71 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -64,7 +64,7 @@ import LoadIface import ToIface import FlagChecker -import Desugar ( mkUsageInfo, mkUsedNames, mkDependencies ) +import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies ) import Id import Annotations import CoreSyn |