%
\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
import NewDemand
import Class
import UniqFM
+import UniqSet
import NameSet
import Name
import CostCentre
import BasicTypes
import Outputable
import FastString
+import Module
import Data.List
import Data.Maybe
| IfaceCast IfaceExpr IfaceCoercion
| IfaceLit Literal
| IfaceFCall ForeignCall IfaceType
+ | IfaceTick Module Int
data IfaceNote = IfaceSCC CostCentre
| IfaceInlineMe
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.
-- 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 = []
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 [])
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
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)
projects / ghc-hetmet.git / blobdiff