X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=44ce2359fedbb07009d4b5bdcaf6b725050f40f3;hp=b3dd586da6895bc2f5297e91f800b3b64efe41d3;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=7c3684fce2d0ace4f354e21e14fe8ef2a7aef310 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index b3dd586..44ce235 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -1,33 +1,33 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % -%************************************************************************ -%* * -\section[HsCore]{Core-syntax unfoldings in Haskell interface files} -%* * -%************************************************************************ - -We could either use this, or parameterise @GenCoreExpr@ on @Types@ and -@TyVars@ as well. Currently trying the former... MEGA SIGH. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module IfaceSyn ( module IfaceType, -- Re-export all this IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), - IfaceExpr(..), IfaceAlt, IfaceNote(..), + IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), -- Misc - visibleIfConDecls, extractIfFamInsts, + ifaceDeclSubBndrs, visibleIfConDecls, -- Equality - IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, - eqIfDecl, eqIfInst, eqIfRule, checkBootDecl, + GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy, + eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl, -- Pretty printing - pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead + pprIfaceExpr, pprIfaceDeclHead ) where #include "HsVersions.h" @@ -35,18 +35,21 @@ module IfaceSyn ( import CoreSyn import IfaceType -import NewDemand ( StrictSig, pprIfaceStrictSig ) -import Class ( FunDep, DefMeth, pprFundeps ) -import OccName ( OccName, parenSymOcc, occNameFS, - OccSet, unionOccSets, unitOccSet, occSetElts ) -import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM ) -import CostCentre ( CostCentre, pprCostCentreCore ) -import Literal ( Literal ) -import ForeignCall ( ForeignCall ) -import BasicTypes ( Arity, Activation(..), StrictnessMark, OverlapFlag, - RecFlag(..), Boxity(..), tupleParens ) +import NewDemand +import Class +import UniqFM +import NameSet +import Name +import CostCentre +import Literal +import ForeignCall +import BasicTypes import Outputable import FastString +import Module + +import Data.List +import Data.Maybe infixl 3 &&& infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType` @@ -80,16 +83,23 @@ data IfaceDecl -- been compiled with -- different flags to the -- current compilation unit - ifFamInst :: Maybe IfaceFamInst + ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family + -- Invariant: + -- ifCons /= IfOpenDataTyCon + -- for family instances } | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifOpenSyn :: Bool, -- Is an open family? - ifSynRhs :: IfaceType -- Type for an ordinary + ifSynRhs :: IfaceType, -- Type for an ordinary -- synonym and kind for an -- open family + ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) + -- Just <=> instance of family + -- Invariant: ifOpenSyn == False + -- for family instances } | IfaceClass { ifCtxt :: IfaceContext, -- Context... @@ -101,7 +111,8 @@ data IfaceDecl ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive? } - | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move + -- beyond .NET ifExtName :: Maybe FastString } data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType @@ -112,20 +123,18 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType data IfaceConDecls = IfAbstractTyCon -- No info | IfOpenDataTyCon -- Open data family - | IfOpenNewTyCon -- Open newtype family | IfDataTyCon [IfaceConDecl] -- data type decls | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls IfAbstractTyCon = [] visibleIfConDecls IfOpenDataTyCon = [] -visibleIfConDecls IfOpenNewTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] data IfaceConDecl = IfCon { - ifConOcc :: OccName, -- Constructor name + ifConOcc :: OccName, -- Constructor name ifConInfix :: Bool, -- True <=> declared infix ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars ifConExTvs :: [IfaceTvBndr], -- Existential tyvars @@ -137,11 +146,11 @@ data IfaceConDecl -- or 1-1 corresp with arg tys data IfaceInst - = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with + = IfaceInst { ifInstCls :: Name, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance - ifDFun :: OccName, -- The dfun + ifDFun :: Name, -- The dfun ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance + ifInstOrph :: Maybe OccName } -- See Note [Orphans] -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, @@ -150,21 +159,17 @@ data IfaceInst -- and if the head does not change it won't be used if it wasn't before data IfaceFamInst - = IfaceFamInst { ifFamInstTyCon :: IfaceTyCon -- Family tycon - , ifFamInstTys :: [IfaceType] -- Instance types + = IfaceFamInst { ifFamInstFam :: Name -- Family tycon + , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types + , ifFamInstTyCon :: IfaceTyCon -- Instance decl } -extractIfFamInsts :: [IfaceDecl] -> [(IfaceFamInst, IfaceDecl)] -extractIfFamInsts decls = - [(famInst, decl) | decl@IfaceData {ifFamInst = Just famInst} <- decls] - -- !!!TODO: we also need a similar case for synonyms - data IfaceRule = IfaceRule { ifRuleName :: RuleName, ifActivation :: Activation, ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars - ifRuleHead :: IfaceExtName, -- Head of lhs + ifRuleHead :: Name, -- Head of lhs ifRuleArgs :: [IfaceExpr], -- Args of LHS ifRuleRhs :: IfaceExpr, ifRuleOrph :: Maybe OccName -- Just like IfaceInst @@ -190,7 +195,7 @@ data IfaceInfoItem | HsInline Activation | HsUnfold IfaceExpr | HsNoCafRefs - | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo + | 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. @@ -200,7 +205,7 @@ data IfaceInfoItem -------------------------------- data IfaceExpr = IfaceLcl FastString - | IfaceExt IfaceExtName + | IfaceExt Name | IfaceType IfaceType | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr @@ -211,6 +216,7 @@ data IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal | IfaceFCall ForeignCall IfaceType + | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre | IfaceInlineMe @@ -222,25 +228,198 @@ type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr) -- thus saving bulk in interface files data IfaceConAlt = IfaceDefault - | IfaceDataAlt OccName + | IfaceDataAlt Name | IfaceTupleAlt Boxity | IfaceLitAlt Literal data IfaceBinding - = IfaceNonRec IfaceIdBndr IfaceExpr - | IfaceRec [(IfaceIdBndr, IfaceExpr)] + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] + +-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too +-- It's used for *non-top-level* let/rec binders +-- See Note [IdInfo on nested let-bindings] +data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo \end{code} +Note [IdInfo on nested let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occasionally we want to preserve IdInfo on nested let bindings The one +that came up was a NOINLINE pragma on a let-binding inside an INLINE +function. The user (Duncan Coutts) really wanted the NOINLINE control +to cross the separate compilation boundary. -%************************************************************************ -%* * -\subsection[HsCore-print]{Printing Core unfoldings} -%* * -%************************************************************************ +So a IfaceLetBndr keeps a trimmed-down list of IfaceIdInfo stuff. +Currently we only actually retain InlinePragInfo, but in principle we could +add strictness etc. + + +Note [Orphans]: the ifInstOrph and ifRuleOrph fields +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a module contains any "orphans", then its interface file is read +regardless, so that its instances are not missed. + +Roughly speaking, an instance is an orphan if its head (after the =>) +mentions nothing defined in this module. Functional dependencies +complicate the situation though. Consider + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data T = ... + instance C Int T where ... + +This instance is an orphan, because when compiling a third module Y we +might get a constraint (C Int v), and we'd want to improve v to T. So +we must make sure X's instances are loaded, even if we do not directly +use anything from X. + +More precisely, an instance is an orphan iff + + If there are no fundeps, then at least of the names in + the instance head is locally defined. + + If there are fundeps, then for every fundep, at least one of the + names free in a *non-determined* part of the instance head is + defined in this module. + +(Note that these conditions hold trivially if the class is locally +defined.) + +Note [Versioning of instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Now consider versioning. If we *use* an instance decl in one compilation, +we'll depend on the dfun id for that instance, so we'll recompile if it changes. +But suppose we *don't* (currently) use an instance! We must recompile if +the instance is changed in such a way that it becomes important. (This would +only matter with overlapping instances, else the importing module wouldn't have +compiled before and the recompilation check is irrelevant.) + +The is_orph field is set to (Just n) if the instance is not an orphan. +The 'n' is *any* of the locally-defined names mentioned anywhere in the +instance head. This name is used for versioning; the instance decl is +considered part of the defn of this 'n'. + +I'm worried about whether this works right if we pick a name from +a functionally-dependent part of the instance decl. E.g. + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data S = ... + data T = ... + instance C S T where ... + +If we base the instance verion on T, I'm worried that changing S to S' +would change T's version, but not S or S'. But an importing module might +not depend on T, and so might not be recompiled even though the new instance +(C S' T) might be relevant. I have not been able to make a concrete example, +and it seems deeply obscure, so I'm going to leave it for now. + + +Note [Versioning of rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A rule that is not an orphan has an ifRuleOrph field of (Just n), where +n appears on the LHS of the rule; any change in the rule changes the version of n. ------------------------------ Printing IfaceDecl ------------------------------------ \begin{code} +-- ----------------------------------------------------------------------------- +-- Utils on IfaceSyn + +ifaceDeclSubBndrs :: IfaceDecl -> [OccName] +-- *Excludes* the 'main' name, but *includes* the implicitly-bound names +-- Deeply revolting, because it has to predict what gets bound, +-- especially the question of whether there's a wrapper for a datacon + +-- N.B. the set of names returned here *must* match the set of +-- TyThings returned by HscTypes.implicitTyThings, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. +ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] + +-- Newtype +ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, + ifCons = IfNewTyCon ( + IfCon { ifConOcc = con_occ, + ifConFields = fields + }), + ifFamInst = famInst}) + = -- fields (names of selectors) + fields ++ + -- implicit coerion and (possibly) family instance coercion + (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ + -- 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 + ++ concatMap dc_occs cons + where + dc_occs con_decl + | has_wrapper = [con_occ, work_occ, wrap_occ] + | otherwise = [con_occ, work_occ] + where + 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 + +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) + = -- dictionary datatype: + -- type constructor + tc_occ : + -- (possibly) newtype coercion + co_occs ++ + -- data constructor (DataCon namespace) + -- data worker (Id namespace) + -- no wrapper (class dictionaries never have a wrapper) + [dc_occ, dcww_occ] ++ + -- associated types + [ifName at | at <- ats ] ++ + -- superclass selectors + [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++ + -- operation selectors + [op | IfaceClassOp op _ _ <- sigs] + where + n_ctxt = length sc_ctxt + n_sigs = length sigs + tc_occ = mkClassTyConOcc cls_occ + dc_occ = mkClassDataConOcc cls_occ + co_occs | is_newtype = [mkNewTyCoOcc tc_occ] + | otherwise = [] + dcww_occ = mkDataConWorkerOcc dc_occ + is_newtype = n_sigs + n_ctxt == 1 -- Sigh + +ifaceDeclSubBndrs _other = [] + +-- coercion for data/newtype family instances +famInstCo Nothing baseOcc = [] +famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] + +----------------------------- Printing IfaceDecl ------------------------------ + instance Outputable IfaceDecl where ppr = pprIfaceDecl @@ -252,9 +431,10 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifOpenSyn = False, ifSynRhs = mono_ty}) + ifOpenSyn = False, ifSynRhs = mono_ty, + ifFamInst = mbFamInst}) = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) - 4 (equals <+> ppr mono_ty) + 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst]) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifOpenSyn = True, ifSynRhs = mono_ty}) @@ -273,7 +453,6 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, IfOpenDataTyCon -> ptext SLIT("data family") IfDataTyCon _ -> ptext SLIT("data") IfNewTyCon _ -> ptext SLIT("newtype") - IfOpenNewTyCon -> ptext SLIT("newtype family") pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifATs = ats, ifSigs = sigs, @@ -299,12 +478,12 @@ pprIfaceDeclHead context thing tyvars pprIfaceTvBndrs tyvars] pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}") -pp_condecls tc IfOpenNewTyCon = empty pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c pp_condecls tc IfOpenDataTyCon = empty pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map (pprIfaceConDecl tc) cs)) +pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc pprIfaceConDecl tc (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, @@ -318,14 +497,18 @@ pprIfaceConDecl tc else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))] where main_payload = ppr name <+> dcolon <+> - pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) (ppr con_tau) + pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) | (tv,ty) <- eq_spec] - con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app]) - tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) - [IfaceTyVar tv | (tv,_) <- univ_tvs] - -- Gruesome, but jsut for debug print + + -- A bit gruesome this, but we can't form the full con_tau, and ppr it, + -- because we don't have a Name for the tycon, only an OccName + pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of + (t:ts) -> fsep (t : map (arrow <+>) ts) + [] -> panic "pp_con_taus" + + pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs] instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, @@ -340,15 +523,19 @@ instance Outputable IfaceInst where ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, ifInstCls = cls, ifInstTys = mb_tcs}) = hang (ptext SLIT("instance") <+> ppr flag - <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs)) + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) - where - ppr_mb Nothing = dot - ppr_mb (Just tc) = ppr tc instance Outputable IfaceFamInst where - ppr (IfaceFamInst {ifFamInstTyCon = tycon, ifFamInstTys = tys}) - = ppr tycon <+> hsep (map ppr tys) + ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, + ifFamInstTyCon = tycon_id}) + = hang (ptext SLIT("family instance") <+> + ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) + 2 (equals <+> ppr tycon_id) + +ppr_rough :: Maybe IfaceTyCon -> SDoc +ppr_rough Nothing = dot +ppr_rough (Just tc) = ppr tc \end{code} @@ -366,6 +553,7 @@ pprIfaceExpr add_par (IfaceLcl v) = ppr v pprIfaceExpr add_par (IfaceExt v) = ppr v pprIfaceExpr add_par (IfaceLit l) = ppr l pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr add_par (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix) pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) @@ -416,8 +604,9 @@ ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs) ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) -ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty, - equals <+> pprIfaceExpr noParens rhs] +ppr_bind (IfLetBndr b ty info, rhs) + = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info), + equals <+> pprIfaceExpr noParens rhs] ------------------ pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args) @@ -429,6 +618,7 @@ instance Outputable IfaceNote where ppr IfaceInlineMe = ptext SLIT("__inline_me") ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s) + instance Outputable IfaceConAlt where ppr IfaceDefault = text "DEFAULT" ppr (IfaceLitAlt l) = ppr l @@ -438,16 +628,17 @@ instance Outputable IfaceConAlt where ------------------ instance Outputable IfaceIdInfo where - ppr NoInfo = empty - ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}") + ppr NoInfo = empty + ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr is) <+> ptext SLIT("-}") -ppr_hs_info (HsUnfold unf) = ptext SLIT("Unfolding:") <+> +instance Outputable IfaceInfoItem where + ppr (HsUnfold unf) = ptext SLIT("Unfolding:") <+> parens (pprIfaceExpr noParens unf) -ppr_hs_info (HsInline act) = ptext SLIT("Inline:") <+> ppr act -ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity -ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str -ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs") -ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a + ppr (HsInline act) = ptext SLIT("Inline:") <+> ppr act + 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} @@ -457,23 +648,25 @@ ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a %* * %************************************************************************ -Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is -EqBut, which gives the set of *locally-defined* things whose version must be equal -for the whole thing to be equal. So the key function is eqIfExt, which compares -IfaceExtNames. +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. \begin{code} -data IfaceEq +data GenIfaceEq a = Equal -- Definitely exactly the same | NotEqual -- Definitely different - | EqBut OccSet -- The same provided these local things have not changed + | EqBut a -- The same provided these Names have not changed + +type IfaceEq = GenIfaceEq NameSet instance Outputable IfaceEq where ppr Equal = ptext SLIT("Equal") ppr NotEqual = ptext SLIT("NotEqual") - ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (occSetElts occset) + ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset) bool :: Bool -> IfaceEq bool True = Equal @@ -491,23 +684,18 @@ zapEq other = other (&&&) :: IfaceEq -> IfaceEq -> IfaceEq Equal &&& x = x NotEqual &&& x = NotEqual -EqBut occs &&& Equal = EqBut occs -EqBut occs &&& NotEqual = NotEqual -EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2) +EqBut nms &&& Equal = EqBut nms +EqBut nms &&& NotEqual = NotEqual +EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2) ---------------------- -eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq -- This function is the core of the EqBut stuff -eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2) -eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2) -eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1) -eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1) -eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1) -eqIfExt n1 n2 = NotEqual -\end{code} - +-- 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 -\begin{code} --------------------- checkBootDecl :: IfaceDecl -- The boot decl -> IfaceDecl -- The real decl @@ -566,15 +754,10 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) -- 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 - where - Nothing `eqIfTc_fam` Nothing = Equal - (Just (IfaceFamInst fam1 tys1)) - `eqIfTc_fam` (Just (IfaceFamInst fam2 tys2)) = - fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2 - _ `eqIfTc_fam` _ = NotEqual 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) ) @@ -595,10 +778,22 @@ eqIfDecl _ _ = NotEqual -- default case 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 d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2) -- All other changes are handled via the version info on the dfun +eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2) +-- All other changes are handled via the version info on the tycon + eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1) (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2) = bool (n1==n2 && a1==a2 && o1 == o2) &&& @@ -614,7 +809,6 @@ eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal -eq_hsCD env IfOpenNewTyCon IfOpenNewTyCon = Equal eq_hsCD env d1 d2 = NotEqual eq_ConDecl env c1 c2 @@ -655,6 +849,7 @@ eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2 eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2 eq_ifaceExpr env (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 env (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) @@ -672,10 +867,10 @@ eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2) eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2) eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2) - = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2) + = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2) eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2) - = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 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 @@ -776,14 +971,17 @@ 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 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_ifIdBndrs :: ExtEnv [IfaceIdBndr] +eq_ifLetBndrs :: ExtEnv [IfaceLetBndr] eq_ifTvBndrs :: ExtEnv [IfaceTvBndr] eq_ifNakedBndrs :: ExtEnv [FastString] eq_ifBndrs = eq_bndrs_with eq_ifBndr -eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr +eq_ifLetBndrs = eq_bndrs_with eq_ifLetBndr eq_bndrs_with eq 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)