import Maybes
import FastString
import Util
-
+import Coverage
+import IOEnv
import Data.IORef
+
\end{code}
%************************************************************************
%************************************************************************
\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
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)
}}}
-- NB we can't use isLocalId in the orphan test,
-- because isLocalId isn't true of class methods
fn_name = idName fn_id
- lhs_names = fn_name : nameSetToList (exprsFreeNames args)
- -- No need to delete bndrs, because
- -- exprsFreeNames finds only External names
-
- -- A rule is an orphan only if none of the variables
- -- mentioned on its left-hand side are locally defined
- orph = case filter (nameIsLocalOrFrom mod) lhs_names of
- (n:ns) -> Just (nameOccName n)
- [] -> Nothing
rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs',
ru_rough = roughTopNames args,
- ru_local = local_rule, ru_orph = orph }
+ ru_local = local_rule }
; return (Just rule)
} } }
where
projects / ghc-hetmet.git / blobdiff