X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=f86f4b9558ef6d938b5bd77d66ec4099d326dcc6;hp=470a5ea06d7391f1634496244cab5ffb9c222c38;hb=9a81ddfb43b96cfeae2236c9616ca3552250b235;hpb=d436c70d43fb905c63220040168295e473f4b90a diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 470a5ea..f86f4b9 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -9,7 +9,8 @@ module IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceInst(..), IfaceFamInst(..), @@ -27,7 +28,7 @@ module IfaceSyn ( import IfaceType -import NewDemand +import Demand import Annotations import Class import NameSet @@ -104,7 +105,7 @@ data IfaceDecl -- 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 @@ -132,13 +133,13 @@ data IfaceConDecl 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 @@ -149,7 +150,7 @@ data IfaceInst -- 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 } @@ -159,9 +160,10 @@ data IfaceRule 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 } @@ -201,24 +203,40 @@ data IfaceInfoItem = 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 [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 @@ -227,16 +245,15 @@ data IfaceExpr | 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 @@ -247,9 +264,16 @@ data IfaceBinding -- 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 @@ -257,10 +281,8 @@ 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. -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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -504,11 +526,14 @@ pprIfaceConDecl tc = 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 @@ -528,7 +553,7 @@ instance Outputable IfaceRule where 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]) ] @@ -558,6 +583,9 @@ ppr_rough (Just tc) = ppr tc 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) @@ -593,7 +621,7 @@ pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) 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] @@ -609,13 +637,13 @@ pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) 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) @@ -626,13 +654,12 @@ ppr_bind (IfLetBndr b ty info, rhs) ------------------ 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) @@ -652,16 +679,27 @@ instance Outputable IfaceIdDetails where 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 "") <+> parens (ppr e) + ppr (IfCoreUnfold s e) = (if s then ptext (sLit "") 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 pprParendIfaceExpr ns) -- ----------------------------------------------------------------------------- @@ -675,9 +713,10 @@ instance Outputable IfaceInfoItem where -- 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{} = @@ -695,6 +734,10 @@ freeNamesIfDecl d@IfaceClass{} = 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 @@ -753,6 +796,11 @@ freeNamesIfBndr :: IfaceBndr -> NameSet 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 @@ -765,32 +813,48 @@ freeNamesIfIdInfo NoInfo = emptyNameSet 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 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 + + -- 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 r) x) - = freeNamesIfExpr r &&& freeNamesIfExpr x +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 @@ -801,7 +865,8 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc 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 &&& @@ -814,3 +879,28 @@ freeNamesIfRule (IfaceRule _n _a bs f es rhs _o) 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.