pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
- | isTyVar binder = pprKindedTyVarBndr binder
+ | isTyCoVar binder = pprKindedTyVarBndr binder
| otherwise = pprTypedBinder binder $$
ppIdInfo binder (idInfo binder)
-- Lambda bound type variables are preceded by "@"
-pprCoreBinder LambdaBind bndr
- | isDeadBinder bndr
+pprCoreBinder bind_site bndr
= getPprStyle $ \ sty ->
- if debugStyle sty then
- parens (pprTypedBinder bndr)
- else
- char '_'
- | otherwise
- = parens (pprTypedBinder bndr)
-
--- Case bound things don't get a signature or a herald, unless we have debug on
-pprCoreBinder CaseBind bndr
- = getPprStyle $ \ sty ->
- if debugStyle sty then
- parens (pprTypedBinder bndr)
- else
- if isDeadBinder bndr then char '_'
- else pprUntypedBinder bndr
+ pprTypedLCBinder bind_site (debugStyle sty) bndr
pprUntypedBinder :: Var -> SDoc
pprUntypedBinder binder
- | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
+ | isTyCoVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
| otherwise = pprIdBndr binder
+pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
+-- For lambda and case binders, show the unfolding info (usually none)
+pprTypedLCBinder bind_site debug_on var
+ | not debug_on && isDeadBinder var = char '_'
+ | not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info
+ | isTyCoVar var = parens (pprKindedTyVarBndr var)
+ | otherwise = parens (hang (pprIdBndr var)
+ 2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
+ where
+ unf_info = unfoldingInfo (idInfo var)
+ pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
+ | otherwise = empty
+
pprTypedBinder :: Var -> SDoc
-- Print binder with a type or kind signature (not paren'd)
pprTypedBinder binder
- | isTyVar binder = pprKindedTyVarBndr binder
+ | isTyCoVar binder = pprKindedTyVarBndr binder
| otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
pprKindedTyVarBndr :: TyVar -> SDoc
\begin{code}
instance Outputable UnfoldingGuidance where
- ppr UnfoldNever = ptext (sLit "NEVER")
- ppr (InlineRule { ir_info = info, ir_sat = sat })
- = ptext (sLit "InlineRule") <> ppr (sat,info)
- ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
+ ppr UnfNever = ptext (sLit "NEVER")
+ ppr (UnfWhen unsat_ok boring_ok)
+ = ptext (sLit "ALWAYS_IF") <>
+ parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
+ ptext (sLit "boring_ok=") <> ppr boring_ok)
+ ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
= hsep [ ptext (sLit "IF_ARGS"),
brackets (hsep (map int cs)),
int size,
int discount ]
-instance Outputable InlSatFlag where
- ppr InlSat = ptext (sLit "sat")
- ppr InlUnSat = ptext (sLit "unsat")
-
-instance Outputable InlineRuleInfo where
- ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
- ppr InlSmall = ptext (sLit "small")
- ppr InlAlways = ptext (sLit "always")
- ppr InlVanilla = ptext (sLit "-")
+instance Outputable UnfoldingSource where
+ ppr InlineCompulsory = ptext (sLit "Compulsory")
+ ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
+ ppr InlineStable = ptext (sLit "InlineStable")
+ ppr InlineRhs = ptext (sLit "<vanilla>")
instance Outputable Unfolding where
- ppr NoUnfolding = ptext (sLit "No unfolding")
- ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
- ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con
- <+> brackets (pprWithCommas pprParendExpr ops)
- ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
+ ppr NoUnfolding = ptext (sLit "No unfolding")
+ ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
+ ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
+ <+> ppr con
+ <+> brackets (pprWithCommas pprParendExpr ops)
+ ppr (CoreUnfolding { uf_src = src
+ , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
, uf_is_conlike=conlike, uf_is_cheap=cheap
, uf_expandable=exp, uf_guidance=g, uf_arity=arity})
= ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
where
pp_info = fsep $ punctuate comma
- [ ptext (sLit "TopLvl=") <> ppr top
+ [ ptext (sLit "Src=") <> ppr src
+ , ptext (sLit "TopLvl=") <> ppr top
, ptext (sLit "Arity=") <> int arity
, ptext (sLit "Value=") <> ppr hnf
, ptext (sLit "ConLike=") <> ppr conlike
, ptext (sLit "Expandable=") <> ppr exp
, ptext (sLit "Guidance=") <> ppr g ]
pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
- pp_rhs = case g of
- UnfoldNever -> usually_empty
- UnfoldIfGoodArgs {} -> usually_empty
- _other -> pp_tmpl
- usually_empty = ifPprDebug (ptext (sLit "<rhs>"))
+ pp_rhs | isStableSource src = pp_tmpl
+ | otherwise = empty
-- Don't print the RHS or we get a quadratic
-- blowup in the size of the printout!
\end{code}