import CoreSyn
import CostCentre ( pprCostCentreCore )
import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
- idInfo, idInlinePragma, idDemandInfo, idOccInfo
+ idInfo, idInlinePragma, idOccInfo,
+#ifdef DEBUG
+ idDemandInfo,
+#endif
+ globalIdDetails, isGlobalId, isExportedId,
+ isSpecPragmaId, idNewDemandInfo
)
import Var ( isTyVar )
import IdInfo ( IdInfo, megaSeqIdInfo,
- arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
- specInfo, cprInfo, ppCprInfo,
- strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
- cprInfo, ppCprInfo,
+ arityInfo, ppArityInfo,
+ specInfo, ppStrictnessInfo,
workerInfo, ppWorkerInfo,
- tyGenInfo, ppTyGenInfo
+ tyGenInfo, ppTyGenInfo,
+ newStrictnessInfo,
+#ifdef DEBUG
+ cprInfo, ppCprInfo,
+ strictnessInfo,
+#endif
)
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
import PprType ( pprParendType, pprTyVarBndr )
import BasicTypes ( tupleParens )
import PprEnv
+import Util ( lengthIs )
import Outputable
\end{code}
in
add_par $
hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
- 4 (ppr_noparend_expr pe body)
+ 2 (ppr_noparend_expr pe body)
ppr_expr add_par pe expr@(App fun arg)
= case collectArgs expr of { (fun, args) ->
-> tupleParens (tupleTyConBoxity tc) pp_tup_args
where
tc = dataConTyCon dc
- saturated = length val_args == idArity f
+ saturated = val_args `lengthIs` idArity f
- other -> add_par (hang (pOcc pe f) 4 pp_args)
+ other -> add_par (hang (pOcc pe f) 2 pp_args)
- other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args)
+ other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args)
}
ppr_expr add_par pe (Case expr var [(con,args,rhs)])
= add_par $
sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
- nest 4 (sep (punctuate semi (map (ppr_alt pe) alts))),
+ nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))),
char '}'
]
where
= add_par
(hang (ptext SLIT("let {"))
2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
- 4 (ppr_noparend_expr pe rhs),
+ 2 (ppr_noparend_expr pe rhs),
ptext SLIT("} in")])
$$
ppr_noparend_expr pe expr)
#else
ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
= add_par $
- sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
+ sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)],
ppr_parend_expr pe expr]
#endif
= add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
ppr_alt pe (con, args, rhs)
- = hang (ppr_case_pat pe con args) 4 (ppr_noparend_expr pe rhs)
+ = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs)
ppr_case_pat pe con@(DataAlt dc) args
| isTupleTyCon tc
\begin{code}
-- Used for printing dump info
pprCoreBinder LetBind binder
- = vcat [sig, pragmas, ppr binder]
+ = vcat [sig, pprIdDetails binder, pragmas, ppr binder]
where
sig = pprTypedBinder binder
pragmas = ppIdInfo binder (idInfo binder)
pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
pprUntypedBinder binder
- | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
+ | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
| otherwise = pprIdBndr binder
pprTypedBinder binder
-- It's important that the type is parenthesised too, at least when
-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
+-- 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) <+>
- ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
+#ifdef DEBUG
+ ppr (idDemandInfo id) <+>
+#endif
+ ppr (idNewDemandInfo id) <+>
+ ppr (idLBVarInfo id)))
\end{code}
\begin{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 [
- ppFlavourInfo (flavourInfo info),
- ppArityInfo a,
+ = hsep [ ppArityInfo a,
ppTyGenInfo g,
ppWorkerInfo (workerInfo info),
+#ifdef DEBUG
ppStrictnessInfo s,
- ppCafInfo c,
ppCprInfo m,
+#endif
+ ppr (newStrictnessInfo info),
pprCoreRules b p
-- Inline pragma, occ, demand, lbvar info
-- printed out with all binders (when debug is on);
where
a = arityInfo info
g = tyGenInfo info
+#ifdef DEBUG
s = strictnessInfo info
- c = cafInfo info
m = cprInfo info
+#endif
p = specInfo info
\end{code}
pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
pprCoreRule :: SDoc -> CoreRule -> SDoc
-pprCoreRule pp_fn (BuiltinRule _)
- = ifPprDebug (ptext SLIT("A built in rule"))
+pprCoreRule pp_fn (BuiltinRule name _)
+ = ifPprDebug (ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ptext name))
-pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs)
- = doubleQuotes (ptext name) <+>
+pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
+ = doubleQuotes (ptext name) <+> ppr act <+>
sep [
ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
- nest 4 (pp_fn <+> sep (map pprArg tpl_args)),
- nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs)
+ nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
+ nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
] <+> semi
\end{code}
projects / ghc-hetmet.git / blobdiff