X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;h=b4ff2733fdba1ad0b2281d8cc8a246970f75d4c6;hb=3bec818f91e382b882f8de4bdab8036884eb657f;hp=29801f28cdefc3b5343eb4600b68f29ccb71b6cb;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30;p=ghc-hetmet.git diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 29801f2..b4ff273 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -1,50 +1,51 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[Desugar]{@deSugar@: the main function} + +The Desugarer: turning HsSyn into Core. \begin{code} module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" -import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) -import StaticFlags ( opt_SccProfilingOn, - opt_AutoSccsOnAllToplevs, - opt_AutoSccsOnExportedToplevs ) -import DriverPhases ( isHsBoot ) -import HscTypes ( ModGuts(..), HscEnv(..), availsToNameSet, - Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface ) -import HsSyn ( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl ) -import TcRnTypes ( TcGblEnv(..), ImportAvails(..) ) -import MkIface ( mkUsageInfo ) -import Id ( Id, setIdExported, idName ) -import Name ( Name, isExternalName, nameIsLocalOrFrom, nameOccName ) +import DynFlags +import StaticFlags +import HscTypes +import HsSyn +import TcRnTypes +import MkIface +import Id +import Name import CoreSyn -import PprCore ( pprRules, pprCoreExpr ) +import PprCore import DsMonad -import DsExpr ( dsLExpr ) -import DsBinds ( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) ) -import DsForeign ( dsForeigns ) +import DsExpr +import DsBinds +import DsForeign import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. import Module -import UniqFM ( eltsUFM, delFromUFM ) -import PackageConfig ( thPackageId ) -import RdrName ( GlobalRdrEnv ) +import UniqFM +import PackageConfig +import RdrName import NameSet import VarSet -import Rules ( roughTopNames ) -import CoreLint ( showPass, endPass ) -import CoreFVs ( ruleRhsFreeVars, exprsFreeNames ) -import ErrUtils ( doIfSet, dumpIfSet_dyn ) -import ListSetOps ( insertList ) +import Rules +import CoreLint +import CoreFVs +import ErrUtils +import ListSetOps import Outputable -import SrcLoc ( Located(..) ) -import DATA_IOREF ( readIORef ) -import Maybes ( catMaybes ) +import SrcLoc +import Maybes import FastString -import Util ( sortLe ) +import Util +import Coverage +import IOEnv +import Data.IORef + \end{code} %************************************************************************ @@ -54,46 +55,55 @@ import Util ( sortLe ) %************************************************************************ \begin{code} -deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts) +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env - tcg_env@(TcGblEnv { tcg_mod = mod, - tcg_src = hsc_src, - tcg_type_env = type_env, - tcg_imports = imports, - tcg_exports = exports, - tcg_dus = dus, - tcg_inst_uses = dfun_uses_var, - tcg_th_used = th_var, - tcg_keep = keep_var, - tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_deprecs = deprecs, - tcg_binds = binds, - tcg_fords = fords, - tcg_rules = rules, - tcg_insts = insts, - tcg_fam_insts = fam_insts }) + mod_loc + tcg_env@(TcGblEnv { tcg_mod = mod, + tcg_src = hsc_src, + tcg_type_env = type_env, + tcg_imports = imports, + tcg_exports = exports, + tcg_dus = dus, + tcg_inst_uses = dfun_uses_var, + tcg_th_used = th_var, + tcg_keep = keep_var, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_fam_inst_env = fam_inst_env, + tcg_deprecs = deprecs, + tcg_binds = binds, + tcg_fords = fords, + tcg_rules = rules, + tcg_insts = insts, + tcg_fam_insts = fam_insts }) = do { showPass dflags "Desugar" -- Desugar the program ; let export_set = availsToNameSet exports ; let auto_scc = mkAutoScc mod export_set - + ; let noDbgSites = [] ; mb_res <- case ghcMode dflags of - JustTypecheck -> return (Just ([], [], NoStubs)) - _ -> initDs hsc_env mod rdr_env type_env $ do - { core_prs <- dsTopLHsBinds auto_scc binds + JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites)) + _ -> do (binds_cvr,ds_hpc_info) + <- if opt_Hpc + then addCoverageTicksToBinds dflags mod mod_loc binds + else return (binds, noHpcInfo) + initDs hsc_env mod rdr_env type_env $ do + { core_prs <- dsTopLHsBinds auto_scc binds_cvr ; (ds_fords, foreign_prs) <- dsForeigns fords ; let all_prs = foreign_prs ++ core_prs local_bndrs = mkVarSet (map fst all_prs) ; ds_rules <- mappM (dsRule mod local_bndrs) rules - ; return (all_prs, catMaybes ds_rules, ds_fords) + ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info) + ; dbgSites_var <- getBkptSitesDs + ; dbgSites <- ioToIOEnv$ readIORef dbgSites_var + ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, dbgSites) } ; case mb_res of { Nothing -> return Nothing ; - Just (all_prs, ds_rules, ds_fords) -> do + Just (all_prs, ds_rules, ds_fords,ds_hpc_info, dbgSites) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var @@ -140,28 +150,31 @@ deSugar hsc_env le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2 - deps = Deps { dep_mods = sortLe le_dep_mod dep_mods, - dep_pkgs = sortLe (<=) pkgs, - dep_orphs = sortLe le_mod (imp_orphs imports) } + deps = Deps { dep_mods = sortLe le_dep_mod dep_mods, + dep_pkgs = sortLe (<=) pkgs, + dep_orphs = sortLe le_mod (imp_orphs imports), + dep_finsts = sortLe le_mod (imp_finsts imports) } -- sort to get into canonical order mod_guts = ModGuts { - mg_module = mod, - mg_boot = isHsBoot hsc_src, - mg_exports = exports, - mg_deps = deps, - mg_usages = usages, - mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods], - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_deprecs = deprecs, - mg_types = type_env, - mg_insts = insts, - mg_fam_insts = fam_insts, - mg_rules = ds_rules, - mg_binds = ds_binds, - mg_foreign = ds_fords } - + mg_module = mod, + mg_boot = isHsBoot hsc_src, + mg_exports = exports, + mg_deps = deps, + mg_usages = usages, + mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods], + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_deprecs = deprecs, + mg_types = type_env, + mg_insts = insts, + mg_fam_insts = fam_insts, + mg_fam_inst_env = fam_inst_env, + mg_rules = ds_rules, + mg_binds = ds_binds, + mg_foreign = ds_fords, + mg_hpc_info = ds_hpc_info, + mg_dbg_sites = dbgSites } ; return (Just mod_guts) }}}