X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=c844d627f93c6c281965a7708e6cbc3f4d231d01;hb=661c97c65e5fa47177502e592bb763f752b487ac;hp=129ebd0719a11bc5dcef66f16f552270805098c4;hpb=c173e8d155ca61ec53224c39d8cb936ddcc5dbda;p=ghc-hetmet.git diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 129ebd0..c844d62 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 @@ -201,15 +202,27 @@ 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 IfaceExpr + | IfCompulsory IfaceExpr -- Only used for default methods, in fact + + | IfInlineRule Arity + Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring + IfaceExpr + + | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker + -- can simplify to a function in another module. + + | IfDFunUnfold [IfaceExpr] + -------------------------------- data IfaceExpr = IfaceLcl FastString @@ -227,7 +240,6 @@ data IfaceExpr | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre - | IfaceInlineMe | IfaceCoreNote String type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr) @@ -250,6 +262,13 @@ data IfaceBinding data IfaceLetBndr = IfLetBndr FastString 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 @@ -504,10 +523,10 @@ 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 strs)), + ppUnless (null fields) $ + nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] where main_payload = ppr name <+> dcolon <+> pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau @@ -528,7 +547,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 +577,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 +615,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,7 +631,7 @@ 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 (con, bs, rhs) = sep [ppr_con_bs con bs, @@ -626,13 +648,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 +673,23 @@ 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 e) = parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok), + pprParendIfaceExpr e] + ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) + ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") <+> brackets (pprWithCommas pprParendIfaceExpr ns) -- ----------------------------------------------------------------------------- @@ -775,9 +803,15 @@ 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 (IfWrapper _ v) = unitNameSet v +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v