X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=44dd34ad271386d8d25db99c6f0b6de2a44bb2e9;hp=062cd30b1a04a16d81f60742041eb5a9281fbc5c;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=d807cb88e01cd86fa924adbe571886fced7e65d0 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 062cd30..44dd34a 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -9,44 +9,40 @@ module IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), - IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceInst(..), IfaceFamInst(..), -- Misc ifaceDeclSubBndrs, visibleIfConDecls, - -- Equality - GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy, - eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl, - + -- Free Names + freeNamesIfDecl, freeNamesIfRule, + -- Pretty printing pprIfaceExpr, pprIfaceDeclHead ) where #include "HsVersions.h" -import CoreSyn import IfaceType -import NewDemand +import Demand +import Annotations import Class -import UniqFM -import UniqSet import NameSet import Name import CostCentre import Literal import ForeignCall +import Serialized import BasicTypes import Outputable import FastString import Module -import Data.List -import Data.Maybe - infixl 3 &&& -infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType` \end{code} @@ -58,9 +54,10 @@ infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType` \begin{code} data IfaceDecl - = IfaceId { ifName :: OccName, - ifType :: IfaceType, - ifIdInfo :: IfaceIdInfo } + = IfaceId { ifName :: OccName, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo } | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables @@ -86,11 +83,10 @@ data IfaceDecl | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables - ifOpenSyn :: Bool, -- Is an open family? - ifSynRhs :: IfaceType, -- Type for an ordinary - -- synonym and kind for an - -- open family - ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) + ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) + ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn + -- Nothing for an open family + ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family -- Invariant: ifOpenSyn == False -- for family instances @@ -129,6 +125,7 @@ visibleIfConDecls (IfNewTyCon c) = [c] data IfaceConDecl = IfCon { ifConOcc :: OccName, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper ifConInfix :: Bool, -- True <=> declared infix ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars ifConExTvs :: [IfaceTvBndr], -- Existential tyvars @@ -136,7 +133,7 @@ data IfaceConDecl ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types ifConFields :: [OccName], -- ...ditto... (field labels) - ifConStricts :: [StrictnessMark]} -- Empty (meaning all lazy), + ifConStricts :: [HsBang]} -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys data IfaceInst @@ -169,6 +166,24 @@ data IfaceRule ifRuleOrph :: Maybe OccName -- Just like IfaceInst } +data IfaceAnnotation + = IfaceAnnotation { + ifAnnotatedTarget :: IfaceAnnTarget, + ifAnnotatedValue :: Serialized + } + +type IfaceAnnTarget = AnnTarget OccName + +-- We only serialise the IdDetails of top-level Ids, and even then +-- we only need a very limited selection. Notably, none of the +-- implicit ones are needed here, becuase they are not put it +-- interface files + +data IfaceIdDetails + = IfVanillaId + | IfRecSelId IfaceTyCon Bool + | IfDFunId + data IfaceIdInfo = NoInfo -- When writing interface file without -O | HasInfo [IfaceInfoItem] -- Has info, and here it is @@ -186,16 +201,28 @@ data IfaceIdInfo data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig - | HsInline Activation - | HsUnfold IfaceExpr + | HsInline InlinePragma + | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs - | HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo - -- for why we want arity here. - -- NB: we need IfaceExtName (not just OccName) because the worker - -- can simplify to a function in another module. + -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. +data IfaceUnfolding + = IfCoreUnfold IfaceExpr + | IfCompulsory IfaceExpr -- Only used for default methods, in fact + + | IfInlineRule Arity + Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring + IfaceExpr + + | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker + -- can simplify to a function in another module. + + | IfDFunUnfold [IfaceExpr] + -------------------------------- data IfaceExpr = IfaceLcl FastString @@ -213,7 +240,6 @@ data IfaceExpr | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre - | IfaceInlineMe | IfaceCoreNote String type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr) @@ -236,6 +262,13 @@ data IfaceBinding data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo \end{code} +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + Note [IdInfo on nested let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Occasionally we want to preserve IdInfo on nested let bindings. The one @@ -342,28 +375,22 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] -- Newtype ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfNewTyCon ( - IfCon { ifConOcc = con_occ, - ifConFields = fields - }), + IfCon { ifConOcc = con_occ }), ifFamInst = famInst}) - = -- fields (names of selectors) - fields ++ - -- implicit coerion and (possibly) family instance coercion + = -- implicit coerion and (possibly) family instance coercion (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ - -- data constructor and worker (newtypes don't have a wrapper) + -- data constructor and worker (newtypes don't have a wrapper) [con_occ, mkDataConWorkerOcc con_occ] ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfDataTyCon cons, ifFamInst = famInst}) - = -- fields (names of selectors) - nub (concatMap ifConFields cons) -- Eliminate duplicate fields - -- (possibly) family instance coercion; - -- there is no implicit coercion for non-newtypes - ++ famInstCo famInst tc_occ - -- for each data constructor in order, - -- data constructor, worker, and (possibly) wrapper + = -- (possibly) family instance coercion; + -- there is no implicit coercion for non-newtypes + famInstCo famInst tc_occ + -- for each data constructor in order, + -- data constructor, worker, and (possibly) wrapper ++ concatMap dc_occs cons where dc_occs con_decl @@ -373,11 +400,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, con_occ = ifConOcc con_decl -- DataCon namespace wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace work_occ = mkDataConWorkerOcc con_occ -- Id namespace - strs = ifConStricts con_decl - has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) - || not (null . ifConEqSpec $ con_decl) - || isJust famInst - -- ToDo: may miss strictness in existential dicts + has_wrapper = ifConWrapper con_decl -- This is the reason for + -- having the ifConWrapper field! ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs, ifATs = ats }) @@ -423,23 +447,25 @@ instance Outputable IfaceDecl where ppr = pprIfaceDecl pprIfaceDecl :: IfaceDecl -> SDoc -pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info}) +pprIfaceDecl (IfaceId {ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info}) = sep [ ppr var <+> dcolon <+> ppr ty, + nest 2 (ppr details), nest 2 (ppr info) ] pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifOpenSyn = False, ifSynRhs = mono_ty, + ifSynRhs = Just mono_ty, ifFamInst = mbFamInst}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst]) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifOpenSyn = True, ifSynRhs = mono_ty}) + ifSynRhs = Nothing, ifSynKind = kind }) = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) - 4 (dcolon <+> ppr mono_ty) + 4 (dcolon <+> ppr kind) pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, @@ -490,17 +516,21 @@ pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc pprIfaceConDecl tc - (IfCon { ifConOcc = name, ifConInfix = is_infix, + (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, ifConStricts = strs, ifConFields = fields }) = sep [main_payload, if is_infix then ptext (sLit "Infix") else empty, - if null strs then empty - else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)), - if null fields then empty - else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + if has_wrap then ptext (sLit "HasWrapper") else empty, + ppUnless (null strs) $ + nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), + ppUnless (null fields) $ + nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] where + ppr_bang HsNoBang = char '_' -- Want to see these + ppr_bang bang = ppr bang + main_payload = ppr name <+> dcolon <+> pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau @@ -520,7 +550,7 @@ instance Outputable IfaceRule where ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) = sep [hsep [doubleQuotes (ftext name), ppr act, ptext (sLit "forall") <+> pprIfaceBndrs bndrs], - nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args), + nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), ptext (sLit "=") <+> ppr rhs]) ] @@ -550,6 +580,9 @@ ppr_rough (Just tc) = ppr tc instance Outputable IfaceExpr where ppr e = pprIfaceExpr noParens e +pprParendIfaceExpr :: IfaceExpr -> SDoc +pprParendIfaceExpr = pprIfaceExpr parens + pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) @@ -585,7 +618,7 @@ pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) nest 2 (sep (map ppr_alt alts)) <+> char '}']) pprIfaceExpr _ (IfaceCast expr co) - = sep [pprIfaceExpr parens expr, + = sep [pprParendIfaceExpr expr, nest 2 (ptext (sLit "`cast`")), pprParendIfaceType co] @@ -601,7 +634,7 @@ pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) ptext (sLit "} in"), pprIfaceExpr noParens body]) -pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body) +pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body) ppr_alt :: (IfaceConAlt, [FastString], IfaceExpr) -> SDoc ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, @@ -618,13 +651,12 @@ ppr_bind (IfLetBndr b ty info, rhs) ------------------ pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc -pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args) -pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args) +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprParendIfaceExpr arg) : args) +pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) ------------------ instance Outputable IfaceNote where ppr (IfaceSCC cc) = pprCostCentreCore cc - ppr IfaceInlineMe = ptext (sLit "__inline_me") ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s) @@ -636,397 +668,230 @@ instance Outputable IfaceConAlt where -- IfaceTupleAlt is handled by the case-alternative printer ------------------ +instance Outputable IfaceIdDetails where + ppr IfVanillaId = empty + ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc + <+> if b then ptext (sLit "") else empty + ppr IfDFunId = ptext (sLit "DFunId") + instance Outputable IfaceIdInfo where ppr NoInfo = empty - ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}") + ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}") instance Outputable IfaceInfoItem where - ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+> - parens (pprIfaceExpr noParens unf) - ppr (HsInline act) = ptext (sLit "Inline:") <+> ppr act + ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)")) + <> colon <+> ppr unf + ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") - ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a -\end{code} - -%************************************************************************ -%* * - Equality, for interface file version generaion only -%* * -%************************************************************************ +instance Outputable IfaceUnfolding where + ppr (IfCompulsory e) = ptext (sLit "") <+> parens (ppr e) + ppr (IfCoreUnfold e) = parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok), + pprParendIfaceExpr e] + ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) + ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") <+> brackets (pprWithCommas pprParendIfaceExpr ns) -Equality over IfaceSyn returns an IfaceEq, not a Bool. The new -constructor is EqBut, which gives the set of things whose version must -be equal for the whole thing to be equal. So the key function is -eqIfExt, which compares Names. -Of course, equality is also done modulo alpha conversion. +-- ----------------------------------------------------------------------------- +-- Finding the Names in IfaceSyn + +-- This is used for dependency analysis in MkIface, so that we +-- fingerprint a declaration before the things that depend on it. It +-- is specific to interface-file fingerprinting in the sense that we +-- don't collect *all* Names: for example, the DFun of an instance is +-- recorded textually rather than by its fingerprint when +-- fingerprinting the instance, so DFuns are not dependencies. + +freeNamesIfDecl :: IfaceDecl -> NameSet +freeNamesIfDecl (IfaceId _s t d i) = + freeNamesIfType t &&& + freeNamesIfIdInfo i &&& + freeNamesIfIdDetails d +freeNamesIfDecl IfaceForeign{} = + emptyNameSet +freeNamesIfDecl d@IfaceData{} = + freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfTcFam (ifFamInst d) &&& + freeNamesIfContext (ifCtxt d) &&& + freeNamesIfConDecls (ifCons d) +freeNamesIfDecl d@IfaceSyn{} = + freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfSynRhs (ifSynRhs d) &&& + freeNamesIfTcFam (ifFamInst d) +freeNamesIfDecl d@IfaceClass{} = + freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfContext (ifCtxt d) &&& + freeNamesIfDecls (ifATs d) &&& + fnList freeNamesIfClsSig (ifSigs d) + +freeNamesIfIdDetails :: IfaceIdDetails -> NameSet +freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc +freeNamesIfIdDetails _ = emptyNameSet -\begin{code} -data GenIfaceEq a - = Equal -- Definitely exactly the same - | NotEqual -- Definitely different - | EqBut (UniqSet a) -- The same provided these things have not changed - -type IfaceEq = GenIfaceEq Name - -instance Outputable a => Outputable (GenIfaceEq a) where - ppr Equal = ptext (sLit "Equal") - ppr NotEqual = ptext (sLit "NotEqual") - ppr (EqBut occset) = ptext (sLit "EqBut") <+> ppr (uniqSetToList occset) - -bool :: Bool -> IfaceEq -bool True = Equal -bool False = NotEqual - -toBool :: IfaceEq -> Bool -toBool Equal = True -toBool (EqBut _) = True -toBool NotEqual = False - -zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information -zapEq (EqBut _) = Equal -zapEq other = other - -(&&&) :: IfaceEq -> IfaceEq -> IfaceEq -Equal &&& x = x -NotEqual &&& _ = NotEqual -EqBut nms &&& Equal = EqBut nms -EqBut _ &&& NotEqual = NotEqual -EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2) - --- This function is the core of the EqBut stuff --- ASSUMPTION: The left-hand argument is the NEW CODE, and hence --- any Names in the left-hand arg have the correct parent in them. -eqIfExt :: Name -> Name -> IfaceEq -eqIfExt name1 name2 - | name1 == name2 = EqBut (unitNameSet name1) - | otherwise = NotEqual - ---------------------- -checkBootDecl :: IfaceDecl -- The boot decl - -> IfaceDecl -- The real decl - -> Bool -- True <=> compatible -checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _) - = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2) - -checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) - = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2 - -checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) - = ASSERT( ifName d1 == ifName d2 ) - toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> - eq_ifType env (ifSynRhs d1) (ifSynRhs d2) - -checkBootDecl d1@(IfaceData {}) d2@(IfaceData {}) --- We don't check the recursion flags because the boot-one is --- recursive, to be conservative, but the real one may not be. --- I'm not happy with the way recursive flags are dealt with. - = ASSERT( ifName d1 == ifName d2 ) - toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> - eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& - case ifCons d1 of - IfAbstractTyCon -> Equal - cons1 -> eq_hsCD env cons1 (ifCons d2) - -checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {}) - = ASSERT( ifName d1 == ifName d2 ) - toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> - eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&& - case (ifCtxt d1, ifSigs d1) of - ([], []) -> Equal - (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2) &&& - eqListBy (eq_cls_sig env) sigs1 (ifSigs d2) - -checkBootDecl _ _ = False -- default case - ---------------------- -eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq -eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2) - = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2) - -eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) - = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2) - -eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) - = bool (ifName d1 == ifName d2 && - ifRec d1 == ifRec d2 && - ifGadtSyntax d1 == ifGadtSyntax d2 && - ifGeneric d1 == ifGeneric d2) &&& - ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&& - eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> - eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& - eq_hsCD env (ifCons d1) (ifCons d2) - ) - -- The type variables of the data type do not scope - -- over the constructors (any more), but they do scope - -- over the stupid context in the IfaceConDecls - -eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) - = bool (ifName d1 == ifName d2) &&& - ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&& - eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> - eq_ifType env (ifSynRhs d1) (ifSynRhs d2) - ) - -eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {}) - = bool (ifName d1 == ifName d2 && - ifRec d1 == ifRec d2) &&& - eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> - eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& - eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&& - eqListBy eqIfDecl (ifATs d1) (ifATs d2) &&& - eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2) - ) - -eqIfDecl _ _ = NotEqual -- default case - --- Helper -eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq -eqWith = eq_ifTvBndrs emptyEqEnv - -eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType]) - -> Maybe (IfaceTyCon, [IfaceType]) - -> IfaceEq -Nothing `eqIfTc_fam` Nothing = Equal -(Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) = - fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2 -_ `eqIfTc_fam` _ = NotEqual - - ------------------------ -eqIfInst :: IfaceInst -> IfaceInst -> IfaceEq -eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2) --- All other changes are handled via the version info on the dfun - -eqIfFamInst :: IfaceFamInst -> IfaceFamInst -> IfaceEq -eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2) -- All other changes are handled via the version info on the tycon +freeNamesIfSynRhs :: Maybe IfaceType -> NameSet +freeNamesIfSynRhs (Just ty) = freeNamesIfType ty +freeNamesIfSynRhs Nothing = emptyNameSet + +freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet +freeNamesIfTcFam (Just (tc,tys)) = + freeNamesIfTc tc &&& fnList freeNamesIfType tys +freeNamesIfTcFam Nothing = + emptyNameSet + +freeNamesIfContext :: IfaceContext -> NameSet +freeNamesIfContext = fnList freeNamesIfPredType + +freeNamesIfDecls :: [IfaceDecl] -> NameSet +freeNamesIfDecls = fnList freeNamesIfDecl + +freeNamesIfClsSig :: IfaceClassOp -> NameSet +freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty + +freeNamesIfConDecls :: IfaceConDecls -> NameSet +freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c +freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c +freeNamesIfConDecls _ = emptyNameSet + +freeNamesIfConDecl :: IfaceConDecl -> NameSet +freeNamesIfConDecl c = + freeNamesIfTvBndrs (ifConUnivTvs c) &&& + freeNamesIfTvBndrs (ifConExTvs c) &&& + freeNamesIfContext (ifConCtxt c) &&& + fnList freeNamesIfType (ifConArgTys c) &&& + fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints + +freeNamesIfPredType :: IfacePredType -> NameSet +freeNamesIfPredType (IfaceClassP cl tys) = + unitNameSet cl &&& fnList freeNamesIfType tys +freeNamesIfPredType (IfaceIParam _n ty) = + freeNamesIfType ty +freeNamesIfPredType (IfaceEqPred ty1 ty2) = + freeNamesIfType ty1 &&& freeNamesIfType ty2 + +freeNamesIfType :: IfaceType -> NameSet +freeNamesIfType (IfaceTyVar _) = emptyNameSet +freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfacePredTy st) = freeNamesIfPredType st +freeNamesIfType (IfaceTyConApp tc ts) = + freeNamesIfTc tc &&& fnList freeNamesIfType ts +freeNamesIfType (IfaceForAllTy tv t) = + freeNamesIfTvBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t + +freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet +freeNamesIfTvBndrs = fnList freeNamesIfTvBndr + +freeNamesIfBndr :: IfaceBndr -> NameSet +freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b +freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b + +freeNamesIfLetBndr :: IfaceLetBndr -> NameSet +-- Remember IfaceLetBndr is used only for *nested* bindings +-- The cut-down IdInfo never contains any Names, but the type may! +freeNamesIfLetBndr (IfLetBndr _name ty _info) = freeNamesIfType ty + +freeNamesIfTvBndr :: IfaceTvBndr -> NameSet +freeNamesIfTvBndr (_fs,k) = freeNamesIfType k + -- kinds can have Names inside, when the Kind is an equality predicate + +freeNamesIfIdBndr :: IfaceIdBndr -> NameSet +freeNamesIfIdBndr = freeNamesIfTvBndr + +freeNamesIfIdInfo :: IfaceIdInfo -> NameSet +freeNamesIfIdInfo NoInfo = emptyNameSet +freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i + +freeNamesItem :: IfaceInfoItem -> NameSet +freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u +freeNamesItem _ = emptyNameSet + +freeNamesIfUnfold :: IfaceUnfolding -> NameSet +freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e +freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e +freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs + +freeNamesIfExpr :: IfaceExpr -> NameSet +freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as +freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body +freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a +freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co +freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r + +freeNamesIfExpr (IfaceCase s _ ty alts) + = freeNamesIfExpr s + &&& fnList fn_alt alts &&& fn_cons alts + &&& freeNamesIfType ty + where + fn_alt (_con,_bs,r) = freeNamesIfExpr r -eqIfRule :: IfaceRule -> IfaceRule -> IfaceEq -eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1) - (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2) - = bool (n1==n2 && a1==a2 && o1 == o2) &&& - f1 `eqIfExt` f2 &&& - eq_ifBndrs emptyEqEnv bs1 bs2 (\env -> - zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&& - -- zapEq: for the LHSs, ignore the EqBut part - eq_ifaceExpr env rhs1 rhs2) - -eq_hsCD :: EqEnv -> IfaceConDecls -> IfaceConDecls -> IfaceEq -eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) - = eqListBy (eq_ConDecl env) c1 c2 - -eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 -eq_hsCD _ IfAbstractTyCon IfAbstractTyCon = Equal -eq_hsCD _ IfOpenDataTyCon IfOpenDataTyCon = Equal -eq_hsCD _ _ _ = NotEqual - -eq_ConDecl :: EqEnv -> IfaceConDecl -> IfaceConDecl -> IfaceEq -eq_ConDecl env c1 c2 - = bool (ifConOcc c1 == ifConOcc c2 && - ifConInfix c1 == ifConInfix c2 && - ifConStricts c1 == ifConStricts c2 && - ifConFields c1 == ifConFields c2) &&& - eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env -> - eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env -> - eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&& - eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2))) - -eq_hsFD :: EqEnv - -> ([FastString], [FastString]) - -> ([FastString], [FastString]) - -> IfaceEq -eq_hsFD env (ns1,ms1) (ns2,ms2) - = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2 - -eq_cls_sig :: EqEnv -> IfaceClassOp -> IfaceClassOp -> IfaceEq -eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2) - = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2 -\end{code} + -- Depend on the data constructors. Just one will do! + -- Note [Tracking data constructors] + fn_cons [] = emptyNameSet + fn_cons ((IfaceDefault ,_,_) : alts) = fn_cons alts + fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet +freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body -\begin{code} ------------------ -eqIfIdInfo :: IfaceIdInfo -> IfaceIdInfo -> GenIfaceEq Name -eqIfIdInfo NoInfo NoInfo = Equal -eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2 -eqIfIdInfo _ _ = NotEqual - -eq_item :: IfaceInfoItem -> IfaceInfoItem -> IfaceEq -eq_item (HsInline a1) (HsInline a2) = bool (a1 == a2) -eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2) -eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2) -eq_item (HsUnfold u1) (HsUnfold u2) = eq_ifaceExpr emptyEqEnv u1 u2 -eq_item HsNoCafRefs HsNoCafRefs = Equal -eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2) -eq_item _ _ = NotEqual - ------------------ -eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq -eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2 -eq_ifaceExpr _ (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2 -eq_ifaceExpr _ (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2) -eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2 -eq_ifaceExpr _ (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2) -eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2 -eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2 -eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2) -eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2 -eq_ifaceExpr env (IfaceCast e1 co1) (IfaceCast e2 co2) = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2 -eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2 - -eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2) - = eq_ifaceExpr env s1 s2 &&& - eq_ifType env ty1 ty2 &&& - eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2) +freeNamesIfExpr (IfaceLet (IfaceRec as) x) + = fnList fn_pair as &&& freeNamesIfExpr x where - eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2) - = bool (eq_ifaceConAlt c1 c2) &&& - eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2) + fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs -eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2) - = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2) +freeNamesIfExpr _ = emptyNameSet -eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2) - = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2) - where - (bs1,rs1) = unzip as1 - (bs2,rs2) = unzip as2 - - -eq_ifaceExpr _ _ _ = NotEqual - ------------------ -eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool -eq_ifaceConAlt IfaceDefault IfaceDefault = True -eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2 -eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2 -eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2 -eq_ifaceConAlt _ _ = False - ------------------ -eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq -eq_ifaceNote _ (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2) -eq_ifaceNote _ IfaceInlineMe IfaceInlineMe = Equal -eq_ifaceNote _ (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2) -eq_ifaceNote _ _ _ = NotEqual -\end{code} -\begin{code} ---------------------- -eqIfType :: IfaceType -> IfaceType -> IfaceEq -eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2 - -------------------- -eq_ifType :: EqEnv -> IfaceType -> IfaceType -> IfaceEq -eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2 -eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2 -eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2 -eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2 -eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2) -eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2 -eq_ifType _ _ _ = NotEqual - -------------------- -eq_ifTypes :: EqEnv -> [IfaceType] -> [IfaceType] -> IfaceEq -eq_ifTypes env = eqListBy (eq_ifType env) - -------------------- -eq_ifContext :: EqEnv -> [IfacePredType] -> [IfacePredType] -> IfaceEq -eq_ifContext env a b = eqListBy (eq_ifPredType env) a b - -------------------- -eq_ifPredType :: EqEnv -> IfacePredType -> IfacePredType -> IfaceEq -eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2 -eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2 -eq_ifPredType _ _ _ = NotEqual - -------------------- -eqIfTc :: IfaceTyCon -> IfaceTyCon -> IfaceEq -eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2 -eqIfTc IfaceIntTc IfaceIntTc = Equal -eqIfTc IfaceCharTc IfaceCharTc = Equal -eqIfTc IfaceBoolTc IfaceBoolTc = Equal -eqIfTc IfaceListTc IfaceListTc = Equal -eqIfTc IfacePArrTc IfacePArrTc = Equal -eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2) -eqIfTc IfaceLiftedTypeKindTc IfaceLiftedTypeKindTc = Equal -eqIfTc IfaceOpenTypeKindTc IfaceOpenTypeKindTc = Equal -eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal -eqIfTc IfaceUbxTupleKindTc IfaceUbxTupleKindTc = Equal -eqIfTc IfaceArgTypeKindTc IfaceArgTypeKindTc = Equal -eqIfTc _ _ = NotEqual -\end{code} +freeNamesIfTc :: IfaceTyCon -> NameSet +freeNamesIfTc (IfaceTc tc) = unitNameSet tc +-- ToDo: shouldn't we include IfaceIntTc & co.? +freeNamesIfTc _ = emptyNameSet ------------------------------------------------------------ - Support code for equality checking ------------------------------------------------------------ +freeNamesIfRule :: IfaceRule -> NameSet +freeNamesIfRule (IfaceRule _n _a bs f es rhs _o) + = unitNameSet f &&& + fnList freeNamesIfBndr bs &&& + fnList freeNamesIfExpr es &&& + freeNamesIfExpr rhs -\begin{code} ------------------------------------- -type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables - -eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq -eqIfOcc env n1 n2 = case lookupUFM env n1 of - Just n1 -> bool (n1 == n2) - Nothing -> bool (n1 == n2) - -extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv -extendEqEnv env n1 n2 | n1 == n2 = env - | otherwise = addToUFM env n1 n2 - -emptyEqEnv :: EqEnv -emptyEqEnv = emptyUFM - ------------------------------------- -type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq - -eq_ifNakedBndr :: ExtEnv FastString -eq_ifBndr :: ExtEnv IfaceBndr -eq_ifTvBndr :: ExtEnv IfaceTvBndr -eq_ifIdBndr :: ExtEnv IfaceIdBndr - -eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2) - -eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k -eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k -eq_ifBndr _ _ _ _ = NotEqual - -eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2) -eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2) - -eq_ifLetBndr :: EqEnv -> IfaceLetBndr -> IfaceLetBndr -> (EqEnv -> IfaceEq) - -> IfaceEq -eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k - = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2) - -eq_ifBndrs :: ExtEnv [IfaceBndr] -eq_ifLetBndrs :: ExtEnv [IfaceLetBndr] -eq_ifTvBndrs :: ExtEnv [IfaceTvBndr] -eq_ifNakedBndrs :: ExtEnv [FastString] -eq_ifBndrs = eq_bndrs_with eq_ifBndr -eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr -eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr -eq_ifLetBndrs = eq_bndrs_with eq_ifLetBndr - --- eq_bndrs_with :: (a -> a -> IfaceEq) -> ExtEnv a -eq_bndrs_with :: ExtEnv a -> ExtEnv [a] -eq_bndrs_with _ env [] [] k = k env -eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k) -eq_bndrs_with _ _ _ _ _ = NotEqual -\end{code} +-- helpers +(&&&) :: NameSet -> NameSet -> NameSet +(&&&) = unionNameSets -\begin{code} -eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq -eqListBy _ [] [] = Equal -eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys -eqListBy _ _ _ = NotEqual - -eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq -eqMaybeBy _ Nothing Nothing = Equal -eqMaybeBy eq (Just x) (Just y) = eq x y -eqMaybeBy _ _ _ = NotEqual +fnList :: (a -> NameSet) -> [a] -> NameSet +fnList f = foldr (&&&) emptyNameSet . map f \end{code} + +Note [Tracking data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a case expression + case e of { C a -> ...; ... } +You might think that we don't need to include the datacon C +in the free names, because its type will probably show up in +the free names of 'e'. But in rare circumstances this may +not happen. Here's the one that bit me: + + module DynFlags where + import {-# SOURCE #-} Packages( PackageState ) + data DynFlags = DF ... PackageState ... + + module Packages where + import DynFlags + data PackageState = PS ... + lookupModule (df :: DynFlags) + = case df of + DF ...p... -> case p of + PS ... -> ... + +Now, lookupModule depends on DynFlags, but the transitive dependency +on the *locally-defined* type PackageState is not visible. We need +to take account of the use of the data constructor PS in the pattern match.