import IdInfo
import NewDemand
import CoreSyn
+import CoreFVs
import Class
import TyCon
import DataCon
import Type
import TcType
-import TysPrim
import InstEnv
import FamInstEnv
import TcRnMonad
import HscTypes
import DynFlags
+import VarEnv
+import Var
import Name
import NameEnv
import NameSet
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 })
; let { entities = typeEnvElts type_env ;
decls = [ tyThingToIfaceDecl entity
| entity <- entities,
- not (isImplicitTyThing entity
- || isWiredInName (getName entity)) ]
- -- Don't put implicit Ids and class tycons in
- -- the interface file, Nor wired-in things; the
- -- compiler knows about them anyhow
+ let name = getName entity,
+ not (isImplicitTyThing entity),
+ -- No implicit Ids and class tycons in the interface file
+ not (isWiredInName name),
+ -- Nor wired-in things; the compiler knows about them anyhow
+ nameIsLocalOrFrom this_mod name ]
+ -- Sigh: see Note [Root-main Id] in TcRnDriver
; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
; deprecs = mkIfaceDeprec src_deprecs
- ; iface_rules = map coreRuleToIfaceRule rules
+ ; 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,
mi_deps = deps,
mi_usages = usages,
mi_exports = mkIfaceExports exports,
+
+ -- Sort these lexicographically, so that
+ -- the result is stable across compilations
mi_insts = sortLe le_inst iface_insts,
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,
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,
; return (new_iface, no_change_at_all) }
where
- r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
- i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
- i1 `le_fam_inst` i2 = ifFamInstTyConOcc i1 <= ifFamInstTyConOcc i2
+ r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
+ i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2
+ i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2
+
+ le_occ :: Name -> Name -> Bool
+ -- Compare lexicographically by OccName, *not* by unique, because
+ -- the latter is not stable across compilations
+ le_occ n1 n2 = nameOccName n1 <= nameOccName n2
dflags = hsc_dflags hsc_env
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
- ifFamInstTyConOcc = nameOccName . ifaceTyConName . ifFamInstTyCon
+ 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
addVersionInfo ver_fn Nothing new_iface new_decls
-- No old interface, so definitely write a new one!
- = (new_iface { mi_orphan = anyNothing ifInstOrph (mi_insts new_iface)
- || anyNothing ifRuleOrph (mi_rules new_iface)
+ = (new_iface { mi_orphan = not (null orph_insts && null orph_rules)
, mi_finsts = not . null $ mi_fam_insts new_iface
, mi_decls = [(initialVersion, decl) | decl <- new_decls]
, mi_ver_fn = mkIfaceVerCache (zip (repeat initialVersion)
-- 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"
where
occ = ifName new_decl
why = case lookupOccEnv eq_env occ of
- Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:"),
+ Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:") <> ppr names,
nest 2 (braces (fsep (map ppr (occSetElts
(occs `intersectOccSet` changed_occs)))))]
where occs = mkOccSet (map nameOccName (nameSetToList names))
= (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
| otherwise = (non_orphs, d:orphs)
-anyNothing :: (a -> Maybe b) -> [a] -> Bool
-anyNothing p [] = False
-anyNothing p (x:xs) = isNothing (p x) || anyNothing p xs
-
----------------------
mkIfaceDeprec :: Deprecations -> IfaceDeprecs
mkIfaceDeprec NoDeprecs = NoDeprecs
-- If the source has changed and we're in interactive mode, avoid reading
-- an interface; just return the one we might have been supplied with.
- ; ghc_mode <- getGhcMode
- ; if (ghc_mode == Interactive || ghc_mode == JustTypecheck)
- && not source_unchanged then
+ ; let dflags = hsc_dflags hsc_env
+ ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
return (outOfDate, maybe_iface)
else
case maybe_iface of {
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,
= IfaceForeign { ifName = getOccName tycon,
ifExtName = tyConExtName tycon }
- | isPrimTyCon tycon || isFunTyCon tycon
- -- Needed in GHCi for ':info Int#', for example
- = IfaceData { ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
- ifCtxt = [],
- ifCons = IfAbstractTyCon,
- ifGadtSyntax = False,
- ifGeneric = False,
- ifRec = NonRecursive,
- ifFamInst = Nothing }
-
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
(syn_isOpen, syn_tyki) = case synTyConRhs tycon of
- OpenSynTyCon ki -> (True , ki)
- SynonymTyCon ty -> (False, ty)
+ OpenSynTyCon ki _ -> (True , ki)
+ SynonymTyCon ty -> (False, ty)
- ifaceConDecls (NewTyCon { data_con = con }) =
+ ifaceConDecls (NewTyCon { data_con = con }) =
IfNewTyCon (ifaceConDecl con)
- ifaceConDecls (DataTyCon { data_cons = cons }) =
+ ifaceConDecls (DataTyCon { data_cons = cons }) =
IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls OpenDataTyCon = IfOpenDataTyCon
- ifaceConDecls OpenNewTyCon = IfOpenNewTyCon
- ifaceConDecls AbstractTyCon = IfAbstractTyCon
+ ifaceConDecls OpenTyCon {} = IfOpenDataTyCon
+ ifaceConDecls AbstractTyCon = IfAbstractTyCon
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
-- in TcRnDriver for GHCi, when browsing a module, in which case the
--------------------------
instanceToIfaceInst :: Instance -> IfaceInst
instanceToIfaceInst ispec@(Instance { is_dfun = dfun_id, is_flag = oflag,
- is_cls = cls, is_tcs = mb_tcs,
- is_orph = orph })
- = IfaceInst { ifDFun = getName dfun_id,
+ is_cls = cls_name, is_tcs = mb_tcs })
+ = ASSERT( cls_name == className cls )
+ IfaceInst { ifDFun = dfun_name,
ifOFlag = oflag,
- ifInstCls = cls,
+ ifInstCls = cls_name,
ifInstTys = map do_rough mb_tcs,
ifInstOrph = orph }
where
do_rough Nothing = Nothing
do_rough (Just n) = Just (toIfaceTyCon_name n)
+ dfun_name = idName dfun_id
+ mod = nameModule dfun_name
+ is_local name = nameIsLocalOrFrom mod name
+
+ -- Compute orphanhood. See Note [Orphans] in IfaceSyn
+ (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
+ -- Slightly awkward: we need the Class to get the fundeps
+ (tvs, fds) = classTvsFds cls
+ arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
+ orph | is_local cls_name = Just (nameOccName cls_name)
+ | all isJust mb_ns = head mb_ns
+ | otherwise = Nothing
+
+ mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name
+ -- that is not in the "determined" arguments
+ mb_ns | null fds = [choose_one arg_names]
+ | otherwise = map do_one fds
+ do_one (ltvs,rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
+ , not (tv `elem` rtvs)]
+
+ choose_one :: [NameSet] -> Maybe OccName
+ choose_one nss = case nameSetToList (unionManyNameSets nss) of
+ [] -> Nothing
+ (n:ns) -> Just (nameOccName n)
+
--------------------------
famInstToIfaceFamInst :: FamInst -> IfaceFamInst
famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon,
do_rough (Just n) = Just (toIfaceTyCon_name n)
--------------------------
+toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
+ (toIfaceType (idType id))
+ prag_info
+ where
+ -- Stripped-down version of tcIfaceIdInfo
+ -- Change this if you want to export more IdInfo for
+ -- non-top-level Ids. Don't forget to change
+ -- CoreTidy.tidyLetBndr too!
+ --
+ -- See Note [IdInfo on nested let-bindings] in IfaceSyn
+ id_info = idInfo id
+ inline_prag = inlinePragInfo id_info
+ prag_info | isAlwaysActive inline_prag = NoInfo
+ | otherwise = HasInfo [HsInline inline_prag]
+
+--------------------------
toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
| otherwise = Just (HsInline inline_prag)
--------------------------
-coreRuleToIfaceRule :: CoreRule -> IfaceRule
-coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
+coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
+coreRuleToIfaceRule mod (BuiltinRule { ru_fn = fn})
= pprTrace "toHsRule: builtin" (ppr fn) $
bogusIfaceRule fn
-coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
- ru_act = act, ru_bndrs = bndrs,
- ru_args = args, ru_rhs = rhs, ru_orph = orph })
+coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
+ ru_act = act, ru_bndrs = bndrs,
+ ru_args = args, ru_rhs = rhs })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
do_arg arg = toIfaceExpr arg
+ -- Compute orphanhood. See Note [Orphans] in IfaceSyn
+ -- A rule is an orphan only if none of the variables
+ -- mentioned on its left-hand side are locally defined
+ lhs_names = fn : nameSetToList (exprsFreeNames args)
+ -- No need to delete bndrs, because
+ -- exprsFreeNames finds only External names
+
+ orph = case filter (nameIsLocalOrFrom mod) lhs_names of
+ (n:ns) -> Just (nameOccName n)
+ [] -> Nothing
+
bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
= IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive,
toIfaceNote (CoreNote s) = IfaceCoreNote s
---------------------
-toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceIdBndr b) (toIfaceExpr r)
-toIfaceBind (Rec prs) = IfaceRec [(toIfaceIdBndr b, toIfaceExpr r) | (b,r) <- prs]
+toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
+toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
---------------------
toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
| 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
projects / ghc-hetmet.git / blobdiff