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
-- 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 IfaceTyCon Bool
- | IfDFunId
+ | 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)
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")
+ 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
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 _ = 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 &&&