module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
- pprIdRules
+ pprRules
) where
#include "HsVersions.h"
import CoreSyn
import CostCentre ( pprCostCentreCore )
import Var ( Var )
-import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
- idInfo, idInlinePragma, idOccInfo,
-#ifdef OLD_STRICTNESS
- idDemandInfo,
-#endif
- globalIdDetails, isGlobalId, isExportedId,
- isSpecPragmaId, idNewDemandInfo
+import Id ( Id, idType, isDataConWorkId_maybe, idArity,
+ idInfo, globalIdDetails, isGlobalId, isExportedId
)
import Var ( TyVar, isTyVar, tyVarKind )
import IdInfo ( IdInfo, megaSeqIdInfo,
+ inlinePragInfo, occInfo, newDemandInfo,
+ lbvarInfo, hasNoLBVarInfo,
arityInfo, ppArityInfo,
specInfo, pprNewStrictness,
workerInfo, ppWorkerInfo,
- newStrictnessInfo, cafInfo, ppCafInfo,
+ newStrictnessInfo, cafInfo, ppCafInfo, specInfoRules
+ )
+import NewDemand ( isTop )
#ifdef OLD_STRICTNESS
- cprInfo, ppCprInfo,
- strictnessInfo, ppStrictnessInfo,
+import Id ( idDemandInfo )
+import IdInfo ( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo )
#endif
- )
+
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
import Type ( pprParendType, pprType, pprParendKind )
-import BasicTypes ( tupleParens )
+import BasicTypes ( tupleParens, isNoOcc, isAlwaysActive )
import Util ( lengthIs )
import Outputable
import FastString ( mkFastString )
ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
ppr_binding (val_bdr, expr)
= pprBndr LetBind val_bdr $$
- (ppr val_bdr <+> equals <+> pprCoreExpr expr)
+ hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
\end{code}
\begin{code}
other -> add_par (hang (pprParendExpr fun) 2 pp_args)
}
--- gaw 2004
ppr_expr add_par (Case expr var ty [(con,args,rhs)])
= add_par $
- sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr,
+ sep [sep [ptext SLIT("case") {- <+> pprParendType ty -} <+> pprCoreExpr expr,
+ -- Printing the result type is excessive!
hsep [ptext SLIT("of"),
ppr_bndr var,
char '{',
where
ppr_bndr = pprBndr CaseBind
--- gaw 2004
ppr_expr add_par (Case expr var ty alts)
= add_par $
- sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr,
+ sep [sep [ptext SLIT("case") {- <+> pprParendType ty -} <+> pprCoreExpr expr,
ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
char '}'
-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
-pprIdBndr id = ppr id <+>
- (megaSeqIdInfo (idInfo id) `seq`
- -- Useful for poking on black holes
- ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
+pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
+
+pprIdBndrInfo info
+ = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
+ where
+ prag_info = inlinePragInfo info
+ occ_info = occInfo info
+ dmd_info = newDemandInfo info
+ lbv_info = lbvarInfo info
+
+ no_info = isAlwaysActive prag_info && isNoOcc occ_info &&
+ (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
+ hasNoLBVarInfo lbv_info
+
+ doc | no_info = empty
+ | otherwise
+ = brackets $ hcat [ppr prag_info, ppr occ_info,
+ ppr dmd_info, ppr lbv_info
#ifdef OLD_STRICTNESS
- ppr (idDemandInfo id) <+>
+ , ppr (demandInfo id)
#endif
- ppr (idNewDemandInfo id) <+>
- ppr (idLBVarInfo id)))
+ ]
\end{code}
pprIdDetails :: Id -> SDoc
pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
| isExportedId id = ptext SLIT("[Exported]")
- | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
| otherwise = empty
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo b info
- = hsep [ ppArityInfo a,
+ = brackets $
+ vcat [ ppArityInfo a,
ppWorkerInfo (workerInfo info),
ppCafInfo (cafInfo info),
#ifdef OLD_STRICTNESS
ppCprInfo m,
#endif
pprNewStrictness (newStrictnessInfo info),
- vcat (map (pprCoreRule (ppr b)) (rulesRules p))
+ if null rules then empty
+ else ptext SLIT("RULES:") <+> vcat (map pprRule rules)
-- Inline pragma, occ, demand, lbvar info
-- printed out with all binders (when debug is on);
-- see PprCore.pprIdBndr
s = strictnessInfo info
m = cprInfo info
#endif
- p = specInfo info
+ rules = specInfoRules (specInfo info)
\end{code}
\begin{code}
-pprIdRules :: [IdCoreRule] -> SDoc
-pprIdRules rules = vcat (map pprIdRule rules)
+instance Outputable CoreRule where
+ ppr = pprRule
-pprIdRule :: IdCoreRule -> SDoc
-pprIdRule (id,rule) = pprCoreRule (ppr id) rule
+pprRules :: [CoreRule] -> SDoc
+pprRules rules = vcat (map pprRule rules)
-pprCoreRule :: SDoc -> CoreRule -> SDoc
-pprCoreRule pp_fn (BuiltinRule name _)
- = ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ftext name)
+pprRule :: CoreRule -> SDoc
+pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
+ = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
-pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
+pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
+ ru_bndrs = tpl_vars, ru_args = tpl_args,
+ ru_rhs = rhs })
= doubleQuotes (ftext name) <+> ppr act <+>
sep [
ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
- nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
+ nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
] <+> semi
\end{code}
projects / ghc-hetmet.git / blobdiff