X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=02bf543a77f77fa70abd592c496eb3dfdc8bf8ec;hb=b410846772e0ee630b82df31990bf9805b2d1849;hp=21080eee3a5fd4f3a1c48f6ada765fc93e097f58;hpb=526c3af1dc98987b6949f4df73c0debccf9875bd;p=ghc-hetmet.git diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 21080ee..02bf543 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -9,8 +9,9 @@ module IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), - IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), + IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceInst(..), IfaceFamInst(..), -- Misc ifaceDeclSubBndrs, visibleIfConDecls, @@ -24,16 +25,17 @@ module IfaceSyn ( #include "HsVersions.h" -import CoreSyn import IfaceType import NewDemand +import Annotations import Class import NameSet import Name import CostCentre import Literal import ForeignCall +import Serialized import BasicTypes import Outputable import FastString @@ -54,9 +56,10 @@ infixl 3 &&& \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 @@ -82,11 +85,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 @@ -125,6 +127,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 @@ -165,6 +168,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 @@ -182,7 +203,7 @@ data IfaceIdInfo data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig - | HsInline Activation + | HsInline InlinePragma | HsUnfold IfaceExpr | HsNoCafRefs | HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo @@ -338,28 +359,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 @@ -369,11 +384,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 }) @@ -419,23 +431,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, @@ -486,12 +500,13 @@ 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 has_wrap then ptext (sLit "HasWrapper") else empty, if null strs then empty else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)), if null fields then empty @@ -632,6 +647,12 @@ 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 "-}") @@ -639,7 +660,7 @@ instance Outputable IfaceIdInfo where instance Outputable IfaceInfoItem where ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+> parens (pprIfaceExpr noParens unf) - ppr (HsInline act) = ptext (sLit "Inline:") <+> ppr act + 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") @@ -657,24 +678,31 @@ instance Outputable IfaceInfoItem where -- fingerprinting the instance, so DFuns are not dependencies. freeNamesIfDecl :: IfaceDecl -> NameSet -freeNamesIfDecl (IfaceId _s t i) = +freeNamesIfDecl (IfaceId _s t _d i) = freeNamesIfType t &&& freeNamesIfIdInfo i freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = + freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfTcFam (ifFamInst d) &&& freeNamesIfContext (ifCtxt d) &&& freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSyn{} = - freeNamesIfType (ifSynRhs d) &&& + 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) -- 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 @@ -697,6 +725,8 @@ 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 @@ -715,9 +745,24 @@ 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) = freeNamesIfType t +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 + +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 @@ -759,8 +804,11 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc freeNamesIfTc _ = emptyNameSet freeNamesIfRule :: IfaceRule -> NameSet -freeNamesIfRule (IfaceRule _n _a _bs f es rhs _o) - = unitNameSet f &&& fnList freeNamesIfExpr es &&& freeNamesIfExpr rhs +freeNamesIfRule (IfaceRule _n _a bs f es rhs _o) + = unitNameSet f &&& + fnList freeNamesIfBndr bs &&& + fnList freeNamesIfExpr es &&& + freeNamesIfExpr rhs -- helpers (&&&) :: NameSet -> NameSet -> NameSet