IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
- IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..),
+ IfaceBinding(..), IfaceConAlt(..),
+ IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceInst(..), IfaceFamInst(..),
#include "HsVersions.h"
import IfaceType
-
-import NewDemand
+import CoreSyn( DFunArg, dfunArgExprs )
+import PprCore() -- Printing DFunArgs
+import Demand
import Annotations
import Class
import NameSet
import FastString
import Module
-import Data.List
-import Data.Maybe
-
infixl 3 &&&
\end{code}
-- beyond .NET
ifExtName :: Maybe FastString }
-data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
+data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
-- Nothing => no default method
-- Just False => ordinary polymorphic default method
-- Just True => generic default method
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
ifConFields :: [OccName], -- ...ditto... (field labels)
- ifConStricts :: [StrictnessMark]} -- Empty (meaning all lazy),
+ ifConStricts :: [HsBang]} -- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
data IfaceInst
- = IfaceInst { ifInstCls :: Name, -- See comments with
+ = IfaceInst { ifInstCls :: IfExtName, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
- ifDFun :: Name, -- The dfun
+ ifDFun :: IfExtName, -- The dfun
ifOFlag :: OverlapFlag, -- Overlap flag
ifInstOrph :: Maybe OccName } -- See Note [Orphans]
-- There's always a separate IfaceDecl for the DFun, which gives
-- and if the head does not change it won't be used if it wasn't before
data IfaceFamInst
- = IfaceFamInst { ifFamInstFam :: Name -- Family tycon
+ = IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon
, ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
, ifFamInstTyCon :: IfaceTyCon -- Instance decl
}
ifRuleName :: RuleName,
ifActivation :: Activation,
ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
- ifRuleHead :: Name, -- Head of lhs
+ ifRuleHead :: IfExtName, -- Head of lhs
ifRuleArgs :: [IfaceExpr], -- Args of LHS
ifRuleRhs :: IfaceExpr,
+ ifRuleAuto :: Bool,
ifRuleOrph :: Maybe OccName -- Just like IfaceInst
}
data IfaceIdDetails
= IfVanillaId
- | IfRecSelId Bool
- | IfDFunId
+ | IfRecSelId IfaceTyCon Bool
+ | IfDFunId Int -- Number of silent args
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
= HsArity Arity
| HsStrictness StrictSig
| HsInline InlinePragma
- | HsUnfold IfaceExpr
+ | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true
+ IfaceUnfolding -- See Note [Expose recursive functions]
| 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 Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
+ -- Possibly could eliminate the Bool here, the information
+ -- is also in the InlinePragma.
+
+ | IfCompulsory IfaceExpr -- Only used for default methods, in fact
+
+ | IfInlineRule Arity -- INLINE pragmas
+ Bool -- OK to inline even if *un*-saturated
+ Bool -- OK to inline even if context is boring
+ IfaceExpr
+
+ | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName)
+ | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
+ -- another module.
+
+ | IfDFunUnfold [DFunArg IfaceExpr]
+
--------------------------------
data IfaceExpr
- = IfaceLcl FastString
- | IfaceExt Name
+ = IfaceLcl IfLclName
+ | IfaceExt IfExtName
| IfaceType IfaceType
| IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
- | IfaceCase IfaceExpr FastString IfaceType [IfaceAlt]
+ | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt]
| IfaceLet IfaceBinding IfaceExpr
| IfaceNote IfaceNote IfaceExpr
| IfaceCast IfaceExpr IfaceCoercion
| IfaceTick Module Int
data IfaceNote = IfaceSCC CostCentre
- | IfaceInlineMe
| IfaceCoreNote String
-type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
- -- Note: FastString, not IfaceBndr (and same with the case binder)
+type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
+ -- Note: IfLclName, not IfaceBndr (and same with the case binder)
-- We reconstruct the kind/type of the thing from the context
-- thus saving bulk in interface files
data IfaceConAlt = IfaceDefault
- | IfaceDataAlt Name
+ | IfaceDataAlt IfExtName
| IfaceTupleAlt Boxity
| IfaceLitAlt Literal
-- 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
+data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo
\end{code}
+Note [Expose recursive functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For supercompilation we want to put *all* unfoldings in the interface
+file, even for functions that are recursive (or big). So we need to
+know when an unfolding belongs to a loop-breaker so that we can refrain
+from inlining it (except during supercompilation).
+
Note [IdInfo on nested let-bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Occasionally we want to preserve IdInfo on nested let bindings. The one
function. The user (Duncan Coutts) really wanted the NOINLINE control
to cross the separate compilation boundary.
-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.
-
+In general we retain all info that is left by CoreTidy.tidyLetBndr, since
+that is what is seen by importing module with --make
Note [Orphans]: the ifInstOrph and ifRuleOrph 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
- else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
+ ppUnless (null strs) $
+ nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
+ ppUnless (null fields) $
+ nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
where
+ ppr_bang HsNoBang = char '_' -- Want to see these
+ ppr_bang bang = ppr bang
+
main_payload = ppr name <+> dcolon <+>
pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
= sep [hsep [doubleQuotes (ftext name), ppr act,
ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
- nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
+ nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
ptext (sLit "=") <+> ppr rhs])
]
instance Outputable IfaceExpr where
ppr e = pprIfaceExpr noParens e
+pprParendIfaceExpr :: IfaceExpr -> SDoc
+pprParendIfaceExpr = pprIfaceExpr parens
+
pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
nest 2 (sep (map ppr_alt alts)) <+> char '}'])
pprIfaceExpr _ (IfaceCast expr co)
- = sep [pprIfaceExpr parens expr,
+ = sep [pprParendIfaceExpr expr,
nest 2 (ptext (sLit "`cast`")),
pprParendIfaceType co]
ptext (sLit "} in"),
pprIfaceExpr noParens body])
-pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
+pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body)
-ppr_alt :: (IfaceConAlt, [FastString], IfaceExpr) -> SDoc
+ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc
ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
arrow <+> pprIfaceExpr noParens rhs]
-ppr_con_bs :: IfaceConAlt -> [FastString] -> SDoc
+ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc
ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
------------------
pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
-pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprParendIfaceExpr arg) : args)
+pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
------------------
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)
------------------
instance Outputable IfaceIdDetails where
ppr IfVanillaId = empty
- ppr (IfRecSelId b) = ptext (sLit "RecSel")
- <> if b then ptext (sLit "<naughty>") else empty
- ppr IfDFunId = ptext (sLit "DFunId")
+ ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
+ <+> if b then ptext (sLit "<naughty>") else empty
+ ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns)
instance Outputable IfaceIdInfo where
ppr NoInfo = empty
- ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}")
+ ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}")
instance Outputable IfaceInfoItem where
- ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+>
- parens (pprIfaceExpr noParens unf)
+ ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)"))
+ <> colon <+> ppr 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")
- ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a
+instance Outputable IfaceUnfolding where
+ ppr (IfCompulsory e) = ptext (sLit "<compulsory>") <+> parens (ppr e)
+ ppr (IfCoreUnfold s e) = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
+ ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
+ pprParendIfaceExpr e]
+ ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr
+ <+> parens (ptext (sLit "arity") <+> int a)
+ ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr
+ <+> parens (ptext (sLit "arity") <+> int a)
+ ppr (IfDFunUnfold ns) = ptext (sLit "DFun:")
+ <+> brackets (pprWithCommas ppr ns)
-- -----------------------------------------------------------------------------
-- Finding the Names in IfaceSyn
-- fingerprinting the instance, so DFuns are not dependencies.
freeNamesIfDecl :: IfaceDecl -> NameSet
-freeNamesIfDecl (IfaceId _s t _d i) =
+freeNamesIfDecl (IfaceId _s t d i) =
freeNamesIfType t &&&
- freeNamesIfIdInfo i
+ freeNamesIfIdInfo i &&&
+ freeNamesIfIdDetails d
freeNamesIfDecl IfaceForeign{} =
emptyNameSet
freeNamesIfDecl d@IfaceData{} =
freeNamesIfDecls (ifATs d) &&&
fnList freeNamesIfClsSig (ifSigs d)
+freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
+freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc
+freeNamesIfIdDetails _ = emptyNameSet
+
-- All other changes are handled via the version info on the tycon
freeNamesIfSynRhs :: Maybe IfaceType -> NameSet
freeNamesIfSynRhs (Just ty) = freeNamesIfType ty
freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
+freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
+-- Remember IfaceLetBndr is used only for *nested* bindings
+-- The cut-down IdInfo never contains any Names, but the type may!
+freeNamesIfLetBndr (IfLetBndr _name ty _info) = freeNamesIfType ty
+
freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
freeNamesIfTvBndr (_fs,k) = freeNamesIfType k
-- kinds can have Names inside, when the Kind is an equality predicate
freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
freeNamesItem :: IfaceInfoItem -> NameSet
-freeNamesItem (HsUnfold u) = freeNamesIfExpr u
-freeNamesItem (HsWorker wkr _) = unitNameSet wkr
-freeNamesItem _ = emptyNameSet
+freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
+freeNamesItem _ = emptyNameSet
+
+freeNamesIfUnfold :: IfaceUnfolding -> NameSet
+freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v
+freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet
+freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs)
freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
-freeNamesIfExpr (IfaceLam _ body) = freeNamesIfExpr body
+freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co
freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r
freeNamesIfExpr (IfaceCase s _ ty alts)
- = freeNamesIfExpr s &&& freeNamesIfType ty &&& fnList freeNamesIfaceAlt alts
+ = freeNamesIfExpr s
+ &&& fnList fn_alt alts &&& fn_cons alts
+ &&& freeNamesIfType ty
where
- -- no need to look at the constructor, because we'll already have its
- -- parent recorded by the type on the case expression.
- freeNamesIfaceAlt (_con,_bs,r) = freeNamesIfExpr r
+ fn_alt (_con,_bs,r) = freeNamesIfExpr r
-freeNamesIfExpr (IfaceLet (IfaceNonRec _bndr r) x)
- = freeNamesIfExpr r &&& freeNamesIfExpr x
+ -- Depend on the data constructors. Just one will do!
+ -- Note [Tracking data constructors]
+ fn_cons [] = emptyNameSet
+ fn_cons ((IfaceDefault ,_,_) : alts) = fn_cons alts
+ fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
+ fn_cons (_ : _ ) = emptyNameSet
+
+freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
+ = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceLet (IfaceRec as) x)
- = fnList freeNamesIfExpr (map snd as) &&& freeNamesIfExpr x
+ = fnList fn_pair as &&& freeNamesIfExpr x
+ where
+ fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs
freeNamesIfExpr _ = emptyNameSet
-
freeNamesIfTc :: IfaceTyCon -> NameSet
freeNamesIfTc (IfaceTc tc) = unitNameSet tc
-- ToDo: shouldn't we include IfaceIntTc & co.?
freeNamesIfTc _ = emptyNameSet
freeNamesIfRule :: IfaceRule -> NameSet
-freeNamesIfRule (IfaceRule _n _a bs f es rhs _o)
+freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
+ , ifRuleArgs = es, ifRuleRhs = rhs })
= unitNameSet f &&&
fnList freeNamesIfBndr bs &&&
fnList freeNamesIfExpr es &&&
fnList :: (a -> NameSet) -> [a] -> NameSet
fnList f = foldr (&&&) emptyNameSet . map f
\end{code}
+
+Note [Tracking data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a case expression
+ case e of { C a -> ...; ... }
+You might think that we don't need to include the datacon C
+in the free names, because its type will probably show up in
+the free names of 'e'. But in rare circumstances this may
+not happen. Here's the one that bit me:
+
+ module DynFlags where
+ import {-# SOURCE #-} Packages( PackageState )
+ data DynFlags = DF ... PackageState ...
+
+ module Packages where
+ import DynFlags
+ data PackageState = PS ...
+ lookupModule (df :: DynFlags)
+ = case df of
+ DF ...p... -> case p of
+ PS ... -> ...
+
+Now, lookupModule depends on DynFlags, but the transitive dependency
+on the *locally-defined* type PackageState is not visible. We need
+to take account of the use of the data constructor PS in the pattern match.