import Id
import Name
import CoreSyn
+import OccurAnal
import PprCore
import DsMonad
import DsExpr
import Coverage
import IOEnv
import Data.IORef
-
\end{code}
%************************************************************************
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 })
- = do { showPass dflags "Desugar"
+ 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
- ; let noDbgSites = []
- ; mb_res <- case ghcMode dflags of
- 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)
+ ; 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)
- ; dbgSites_var <- getBkptSitesDs
- ; dbgSites <- ioToIOEnv$ readIORef dbgSites_var
- ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, dbgSites)
+ ; 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, dbgSites) -> 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
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_dbg_sites = dbgSites }
+ 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