IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
- IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceUnfolding(..),
+ IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceInst(..), IfaceFamInst(..),
import FastString
import Module
-import Data.List
-import Data.Maybe
-
infixl 3 &&&
\end{code}
\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
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
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
data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
- | HsInline Activation
- | HsUnfold IfaceUnfolding
+ | HsInline InlinePragma
+ | HsUnfold IfaceExpr
| 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
- | IfInlineRule Arity IfaceExpr
- | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker
- -- can simplify to a function in another module.
-
--------------------------------
data IfaceExpr
= IfaceLcl FastString
| IfaceTick Module Int
data IfaceNote = IfaceSCC CostCentre
+ | IfaceInlineMe
| IfaceCoreNote String
type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
-- 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
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 })
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})
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
------------------
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)
-- 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 "<naughty>") 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 "-}")
instance Outputable IfaceInfoItem where
- ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+> ppr unf
- ppr (HsInline act) = ptext (sLit "Inline:") <+> ppr act
+ ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+>
+ parens (pprIfaceExpr noParens 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")
-
-instance Outputable IfaceUnfolding where
- ppr (IfCoreUnfold e) = parens (ppr e)
- ppr (IfInlineRule a e) = ptext (sLit "INLINE:") <+> parens (ptext (sLit "arity") <+> int a) <+> parens (ppr e)
- ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
+ ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a
-- -----------------------------------------------------------------------------
-- 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{} =
freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
freeNamesItem :: IfaceInfoItem -> NameSet
-freeNamesItem (HsUnfold u) = freeNamesIfUnfold u
+freeNamesItem (HsUnfold u) = freeNamesIfExpr u
+freeNamesItem (HsWorker wkr _) = unitNameSet wkr
freeNamesItem _ = emptyNameSet
-freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfInlineRule _ e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v
-
freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
projects / ghc-hetmet.git / blobdiff