X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=564d3a4a7d695aa1c78c6d2654b5e4cfb420df56;hp=6f3e33665d220bbd48100b5bc0529f2544181404;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=d33c0b24a0306cc57161b7ed7ff2510d0b017b11 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 6f3e336..564d3a4 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -195,6 +195,8 @@ import TcRnMonad import HscTypes import DynFlags +import VarEnv +import Var import Name import NameEnv import NameSet @@ -242,10 +244,12 @@ mkIface hsc_env maybe_old_iface mg_deps = deps, mg_rdr_env = rdr_env, mg_fix_env = fix_env, - mg_deprecs = src_deprecs }) + mg_deprecs = src_deprecs, + mg_hpc_info = hpc_info }) (ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, + md_vect_info = vect_info, md_types = type_env, md_exports = exports }) @@ -271,6 +275,7 @@ mkIface hsc_env maybe_old_iface ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts + ; iface_vect_info = flattenVectInfo vect_info ; intermediate_iface = ModIface { mi_module = this_mod, @@ -285,6 +290,8 @@ mkIface hsc_env maybe_old_iface mi_fam_insts= sortLe le_fam_inst iface_fam_insts, mi_rules = sortLe le_rule iface_rules, + mi_vect_info = iface_vect_info, + mi_fixities = fixities, mi_deprecs = deprecs, mi_globals = Just rdr_env, @@ -298,6 +305,7 @@ mkIface hsc_env maybe_old_iface mi_finsts = False, -- Ditto mi_decls = deliberatelyOmitted "decls", mi_ver_fn = deliberatelyOmitted "ver_fn", + mi_hpc = isHpcUsed hpc_info, -- And build the cached values mi_dep_fn = mkIfaceDepCache deprecs, @@ -333,6 +341,20 @@ mkIface hsc_env maybe_old_iface deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) ifFamInstTcName = ifaceTyConName . ifFamInstTyCon + flattenVectInfo (VectInfo { vectInfoVar = vVar + , vectInfoTyCon = vTyCon + }) = + IfaceVectInfo { + ifaceVectInfoVar = [ Var.varName v + | (v, _) <- varEnvElts vVar], + ifaceVectInfoTyCon = [ tyConName t + | (t, t_v) <- nameEnvElts vTyCon + , t /= t_v], + ifaceVectInfoTyConReuse = [ tyConName t + | (t, t_v) <- nameEnvElts vTyCon + , t == t_v] + } + ----------------------------- writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () writeIfaceFile dflags location new_iface @@ -452,7 +474,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { -- If the usages havn't changed either, we don't need to write the interface file no_other_changes = mi_usages new_iface == mi_usages old_iface && - mi_deps new_iface == mi_deps old_iface + mi_deps new_iface == mi_deps old_iface && + mi_hpc new_iface == mi_hpc old_iface no_change_at_all = no_output_change && no_other_changes pp_diffs = vcat [pp_change no_export_change "Export list" @@ -1061,10 +1084,12 @@ tyThingToIfaceDecl (AClass clas) tyThingToIfaceDecl (ATyCon tycon) | isSynTyCon tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, + = IfaceSyn { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, ifOpenSyn = syn_isOpen, - ifSynRhs = toIfaceType syn_tyki } + ifSynRhs = toIfaceType syn_tyki, + ifFamInst = famInstToIface (tyConFamInst_maybe tycon) + } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, @@ -1091,8 +1116,7 @@ tyThingToIfaceDecl (ATyCon tycon) IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls OpenTyCon { otIsNewtype = False } = IfOpenDataTyCon - ifaceConDecls OpenTyCon { otIsNewtype = True } = IfOpenNewTyCon + ifaceConDecls OpenTyCon {} = IfOpenDataTyCon ifaceConDecls AbstractTyCon = IfAbstractTyCon -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used @@ -1338,6 +1362,8 @@ toIfaceVar v | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) -- Foreign calls have special syntax | isExternalName name = IfaceExt name + | Just (TickBox m ix) <- isTickBoxOp_maybe v + = IfaceTick m ix | otherwise = IfaceLcl (getFS name) where name = idName v