X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=2d650c159f54c510cc5d49ce1e814318bc0c08fa;hb=58de6cb725982dd1f57803cc838f233d5fd9c42c;hp=ad4c913df16364291e52ca378b277351c1613cb7;hpb=d33c0b24a0306cc57161b7ed7ff2510d0b017b11;p=ghc-hetmet.git diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index ad4c913..2d650c1 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -4,6 +4,13 @@ % \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 @@ -31,6 +38,7 @@ import IfaceType import NewDemand import Class import UniqFM +import UniqSet import NameSet import Name import CostCentre @@ -39,6 +47,7 @@ import ForeignCall import BasicTypes import Outputable import FastString +import Module import Data.List import Data.Maybe @@ -77,14 +86,21 @@ data IfaceDecl -- current compilation unit 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... @@ -108,14 +124,12 @@ 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] @@ -203,6 +217,7 @@ data IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal | IfaceFCall ForeignCall IfaceType + | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre | IfaceInlineMe @@ -230,7 +245,7 @@ data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo Note [IdInfo on nested let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Occasionally we want to preserve IdInfo on nested let bindings The one +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. @@ -324,57 +339,85 @@ ifaceDeclSubBndrs :: IfaceDecl -> [OccName] -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, - ifSigs = sigs, ifATs = ats }) - = co_occs ++ - [tc_occ, dc_occ, dcww_occ] ++ - [op | IfaceClassOp op _ _ <- sigs] ++ - [ifName at | at <- ats ] ++ - [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] - 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 -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker - | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper - is_newtype = n_sigs + n_ctxt == 1 -- Sigh +-- 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} = [] -ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} - = [] -- Newtype ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, - ifCons = IfNewTyCon ( - IfCon { ifConOcc = con_occ, - ifConFields = fields - }), - ifFamInst = famInst}) - = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ] - ++ famInstCo famInst 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}) - = nub (concatMap ifConFields cons) -- Eliminate duplicate fields - ++ concatMap dc_occs cons + = -- 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 - strs = ifConStricts con_decl - wrap_occ = mkDataConWrapperOcc con_occ - work_occ = mkDataConWorkerOcc con_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 -ifaceDeclSubBndrs _other = [] +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 (IfaceSyn {ifName = tc_occ, + ifFamInst = famInst}) + = famInstCo famInst tc_occ + +ifaceDeclSubBndrs _ = [] -- coercion for data/newtype family instances famInstCo Nothing baseOcc = [] @@ -393,9 +436,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}) @@ -414,7 +458,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, @@ -440,7 +483,6 @@ 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(" |")) @@ -516,6 +558,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 []) @@ -621,14 +664,14 @@ Of course, equality is also done modulo alpha conversion. data GenIfaceEq a = Equal -- Definitely exactly the same | NotEqual -- Definitely different - | EqBut a -- The same provided these Names have not changed + | EqBut (UniqSet a) -- The same provided these things have not changed -type IfaceEq = GenIfaceEq NameSet +type IfaceEq = GenIfaceEq Name -instance Outputable IfaceEq where +instance Outputable a => Outputable (GenIfaceEq a) where ppr Equal = ptext SLIT("Equal") ppr NotEqual = ptext SLIT("NotEqual") - ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset) + ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (uniqSetToList occset) bool :: Bool -> IfaceEq bool True = Equal @@ -716,14 +759,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 (fam1, tys1)) `eqIfTc_fam` (Just (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) ) @@ -744,6 +783,15 @@ 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 @@ -766,7 +814,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 @@ -807,6 +854,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)