diff options
Diffstat (limited to 'compiler/deSugar/Desugar.hs')
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 214 |
1 files changed, 8 insertions, 206 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) } |