import Id
import Name
import CoreSyn
+import OccurAnal
import PprCore
import DsMonad
import DsExpr
import FastString
import Util
import Coverage
-
+import IOEnv
import Data.IORef
\end{code}
deSugar hsc_env
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_deprecs = deprecs,
- tcg_binds = binds,
- tcg_fords = fords,
- tcg_rules = rules,
- tcg_insts = insts,
- tcg_fam_insts = fam_insts })
- = do { showPass dflags "Desugar"
+ 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_inst_env = inst_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,
+ tcg_hpc = other_hpc_info })
+
+ = do { let dflags = hsc_dflags hsc_env
+ ; showPass dflags "Desugar"
-- Desugar the program
; let export_set = availsToNameSet exports
; let auto_scc = mkAutoScc mod export_set
-
- ; mb_res <- case ghcMode dflags of
- JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo))
- _ -> do (binds_cvr,ds_hpc_info)
- <- if opt_Hpc
- then addCoverageTicksToBinds dflags mod mod_loc binds
- else return (binds, noHpcInfo)
+ ; let target = hscTarget dflags
+ ; let hpcInfo = emptyHpcInfo other_hpc_info
+ ; mb_res <- case target of
+ HscNothing -> return (Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
+ _ -> do (binds_cvr,ds_hpc_info, modBreaks)
+ <- if (opt_Hpc
+ || target == HscInterpreted)
+ && (not (isHsBoot hsc_src))
+ then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds
+ else return (binds, hpcInfo, emptyModBreaks)
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, ds_hpc_info)
+ ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
}
; case mb_res of {
Nothing -> return Nothing ;
- Just (all_prs, ds_rules, ds_fords,ds_hpc_info) -> do
+ Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
- ; let final_prs = addExportFlags ghci_mode export_set
+ ; let final_prs = addExportFlags target export_set
keep_alive all_prs ds_rules
ds_binds = [Rec final_prs]
-- Notice that we put the whole lot in a big Rec, even the foreign binds
-- 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_hpc_info = ds_hpc_info }
+ 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_inst_env = inst_env,
+ 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_modBreaks = modBreaks,
+ mg_vect_info = noVectInfo
+ }
; return (Just mod_guts)
}}}
- where
- dflags = hsc_dflags hsc_env
- ghci_mode = ghcMode (hsc_dflags hsc_env)
-
mkAutoScc :: Module -> NameSet -> AutoScc
mkAutoScc mod exports
| not opt_SccProfilingOn -- No profiling
-- it's just because the type checker is rather busy already and
-- I didn't want to pass in yet another mapping.
-addExportFlags ghci_mode exports keep_alive prs rules
+addExportFlags target exports keep_alive prs rules
= [(add_export bndr, rhs) | (bndr,rhs) <- prs]
where
add_export bndr
-- isExternalName separates the user-defined top-level names from those
-- introduced by the type checker.
is_exported :: Name -> Bool
- is_exported | ghci_mode == Interactive = isExternalName
+ is_exported | target == HscInterpreted = isExternalName
| otherwise = (`elemNameSet` exports)
ppr_ds_rules [] = empty
dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
= putSrcSpanDs loc $
- do { let bndrs = [var | RuleBndr (L _ var) <- vars]
+ do { let bndrs = [var | RuleBndr (L _ var) <- vars]
; lhs' <- dsLExpr lhs
; rhs' <- dsLExpr rhs
- ; case decomposeRuleLhs bndrs lhs' of {
+ ; case decomposeRuleLhs (occurAnalyseExpr lhs') of {
Nothing -> do { warnDs msg; return Nothing } ;
- Just (bndrs', fn_id, args) -> do
+ Just (fn_id, args) -> do
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
- { let local_rule = nameIsLocalOrFrom mod fn_name
- -- NB we can't use isLocalId in the orphan test,
- -- because isLocalId isn't true of class methods
+ { let local_rule = isLocalId fn_id
+ -- NB: isLocalId is False of implicit Ids. This is good becuase
+ -- we don't want to attach rules to the bindings of implicit Ids,
+ -- because they don't show up in the bindings until just before code gen
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_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