X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=1908667e1473f0fad80854433dafaf8e738c2693;hp=d13fdad51ad0c1e3bc8e0019cb609c66440c1c20;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4 diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index d13fdad..1908667 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -6,40 +6,28 @@ Printing of Core syntax \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module PprCore ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprCoreAlt, pprRules ) where -#include "HsVersions.h" - import CoreSyn import CostCentre import Var import Id import IdInfo -import NewDemand -#ifdef OLD_STRICTNESS -import Id -import IdInfo -#endif - +import Demand import DataCon import TyCon import Type import Coercion +import StaticFlags import BasicTypes import Util import Outputable import FastString +import Data.Maybe \end{code} %************************************************************************ @@ -74,16 +62,21 @@ instance OutputableBndr b => Outputable (Expr b) where %************************************************************************ \begin{code} +pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc pprTopBinds binds = vcat (map pprTopBind binds) +pprTopBind :: OutputableBndr a => Bind a -> SDoc pprTopBind (NonRec binder expr) - = ppr_binding (binder,expr) $$ text "" - -pprTopBind (Rec binds) - = vcat [ptext SLIT("Rec {"), - vcat (map ppr_binding binds), - ptext SLIT("end Rec }"), - text ""] + = ppr_binding (binder,expr) $$ blankLine + +pprTopBind (Rec []) + = ptext (sLit "Rec { }") +pprTopBind (Rec (b:bs)) + = vcat [ptext (sLit "Rec {"), + ppr_binding b, + vcat [blankLine $$ ppr_binding b | b <- bs], + ptext (sLit "end Rec }"), + blankLine] \end{code} \begin{code} @@ -113,17 +106,19 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) -ppr_expr add_par (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd +ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd -ppr_expr add_par (Var name) = ppr name -ppr_expr add_par (Lit lit) = ppr lit +ppr_expr _ (Var name) = ppr name +ppr_expr _ (Lit lit) = ppr lit ppr_expr add_par (Cast expr co) = add_par $ sep [pprParendExpr expr, - ptext SLIT("`cast`") <+> parens (pprCo co)] + ptext (sLit "`cast`") <+> pprCo co] where - pprCo co = sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)] + pprCo co | opt_SuppressCoercions = ptext (sLit "...") + | otherwise = parens + $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] ppr_expr add_par expr@(Lam _ _) @@ -131,10 +126,10 @@ ppr_expr add_par expr@(Lam _ _) (bndrs, body) = collectBinders expr in add_par $ - hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) 2 (pprCoreExpr body) -ppr_expr add_par expr@(App fun arg) +ppr_expr add_par expr@(App {}) = case collectArgs expr of { (fun, args) -> let pp_args = sep (map pprArg args) @@ -151,16 +146,16 @@ ppr_expr add_par expr@(App fun arg) tc = dataConTyCon dc saturated = val_args `lengthIs` idArity f - other -> add_par (hang (ppr f) 2 pp_args) + _ -> add_par (hang (ppr f) 2 pp_args) - other -> add_par (hang (pprParendExpr fun) 2 pp_args) + _ -> add_par (hang (pprParendExpr fun) 2 pp_args) } ppr_expr add_par (Case expr var ty [(con,args,rhs)]) = add_par $ - sep [sep [ptext SLIT("case") <+> pprCoreExpr expr, + sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, ifPprDebug (braces (ppr ty)), - sep [ptext SLIT("of") <+> ppr_bndr var, + sep [ptext (sLit "of") <+> ppr_bndr var, char '{' <+> ppr_case_pat con args] ], pprCoreExpr rhs, @@ -171,10 +166,10 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)]) ppr_expr add_par (Case expr var ty alts) = add_par $ - sep [sep [ptext SLIT("case") + sep [sep [ptext (sLit "case") <+> pprCoreExpr expr <+> ifPprDebug (braces (ppr ty)), - ptext SLIT("of") <+> ppr_bndr var <+> char '{'], + ptext (sLit "of") <+> ppr_bndr var <+> char '{'], nest 2 (sep (punctuate semi (map pprCoreAlt alts))), char '}' ] @@ -189,45 +184,44 @@ ppr_expr add_par (Case expr var ty alts) ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = add_par $ vcat [ - hsep [ptext SLIT("let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], nest 2 (pprCoreExpr rhs), - ptext SLIT("} in"), + ptext (sLit "} in"), pprCoreExpr body ] --} ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = add_par - (hang (ptext SLIT("let {")) + (hang (ptext (sLit "let {")) 2 (hsep [ppr_binding (val_bdr,rhs), - ptext SLIT("} in")]) + ptext (sLit "} in")]) $$ pprCoreExpr expr) +-} --- general case (recursive case, too) +-- General case (recursive case, too) ppr_expr add_par (Let bind expr) = add_par $ - sep [hang (ptext keyword) 2 (ppr_bind bind), - hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)] + sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")), + pprCoreExpr expr] where keyword = case bind of - Rec _ -> SLIT("__letrec {") - NonRec _ _ -> SLIT("let {") + Rec _ -> (sLit "letrec {") + NonRec _ _ -> (sLit "let {") ppr_expr add_par (Note (SCC cc) expr) = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr]) -ppr_expr add_par (Note InlineMe expr) - = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr - ppr_expr add_par (Note (CoreNote s) expr) = add_par $ - sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)], + sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)], pprParendExpr expr] +pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc pprCoreAlt (con, args, rhs) = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs) -ppr_case_pat con@(DataAlt dc) args +ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc +ppr_case_pat (DataAlt dc) args | isTupleTyCon tc = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow where @@ -239,7 +233,8 @@ ppr_case_pat con args where ppr_bndr = pprBndr CaseBind -pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty +pprArg :: OutputableBndr a => Expr a -> SDoc +pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty pprArg expr = pprParendExpr expr \end{code} @@ -252,100 +247,175 @@ instance OutputableBndr Var where pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder - = vcat [sig, pprIdDetails binder, pragmas] - where - sig = pprTypedBinder binder - pragmas = ppIdInfo binder (idInfo binder) + | isTyCoVar binder = pprKindedTyVarBndr binder + | otherwise = pprTypedBinder binder $$ + ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" -pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr) - --- Case bound things don't get a signature or a herald, unless we have debug on -pprCoreBinder CaseBind bndr +pprCoreBinder bind_site bndr = getPprStyle $ \ sty -> - if debugStyle sty then - parens (pprTypedBinder bndr) - 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 = ptext SLIT("@") <+> pprTyVarBndr binder - | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder) + | isTyCoVar binder = pprKindedTyVarBndr binder + | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) -pprTyVarBndr :: TyVar -> SDoc -pprTyVarBndr tyvar - = getPprStyle $ \ sty -> - if debugStyle sty then - hsep [ppr tyvar, dcolon, pprParendKind kind] - -- See comments with ppDcolon in PprCore.lhs - else - ppr tyvar +pprKindedTyVarBndr :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +pprKindedTyVarBndr tyvar + = ptext (sLit "@") <+> ppr tyvar <> opt_kind where + opt_kind -- Print the kind if not * + | isLiftedTypeKind kind = empty + | otherwise = dcolon <> pprKind kind kind = tyVarKind tyvar -- 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 -> SDoc pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) +pprIdBndrInfo :: IdInfo -> SDoc pprIdBndrInfo info - = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes + = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes where prag_info = inlinePragInfo info occ_info = occInfo info - dmd_info = newDemandInfo info + dmd_info = demandInfo 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 $ hsep [ppr prag_info, ppr occ_info, - ppr dmd_info, ppr lbv_info -#ifdef OLD_STRICTNESS - , ppr (demandInfo id) -#endif - ] + has_prag = not (isDefaultInlinePragma prag_info) + has_occ = not (isNoOcc occ_info) + has_dmd = case dmd_info of { Nothing -> False; Just d -> not (isTop d) } + has_lbv = not (hasNoLBVarInfo lbv_info) + + doc = showAttributes + [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info) + , (has_occ, ptext (sLit "Occ=") <> ppr occ_info) + , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) + , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info) + ] \end{code} -\begin{code} -pprIdDetails :: Id -> SDoc -pprIdDetails id | isGlobalId id = ppr (globalIdDetails id) - | isExportedId id = ptext SLIT("[Exported]") - | otherwise = empty +----------------------------------------------------- +-- IdDetails and IdInfo +----------------------------------------------------- +\begin{code} ppIdInfo :: Id -> IdInfo -> SDoc -ppIdInfo b info - = brackets $ - vcat [ ppArityInfo a, - ppWorkerInfo (workerInfo info), - ppCafInfo (cafInfo info), -#ifdef OLD_STRICTNESS - ppStrictnessInfo s, - ppCprInfo m, -#endif - pprNewStrictness (newStrictnessInfo info), - if null rules then empty - else ptext SLIT("RULES:") <+> vcat (map pprRule rules) - -- Inline pragma, occ, demand, lbvar info +ppIdInfo id info + = showAttributes + [ (True, pp_scope <> ppr (idDetails id)) + , (has_arity, ptext (sLit "Arity=") <> int arity) + , (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info) + , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info) + , (has_unf, ptext (sLit "Unf=") <> ppr unf_info) + , (not (null rules), 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 - ] where - a = arityInfo info -#ifdef OLD_STRICTNESS - s = strictnessInfo info - m = cprInfo info -#endif + pp_scope | isGlobalId id = ptext (sLit "GblId") + | isExportedId id = ptext (sLit "LclIdX") + | otherwise = ptext (sLit "LclId") + + arity = arityInfo info + has_arity = arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = strictnessInfo info + has_strictness = isJust str_info + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + rules = specInfoRules (specInfo info) + +showAttributes :: [(Bool,SDoc)] -> SDoc +showAttributes stuff + | null docs = empty + | otherwise = brackets (sep (punctuate comma docs)) + where + docs = [d | (True,d) <- stuff] +\end{code} + +----------------------------------------------------- +-- Unfolding and UnfoldingGuidance +----------------------------------------------------- + +\begin{code} +instance Outputable UnfoldingGuidance where + 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 UnfoldingSource where + ppr InlineCompulsory = ptext (sLit "Compulsory") + ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w + ppr InlineRule = ptext (sLit "InlineRule") + ppr InlineRhs = ptext (sLit "") + +instance Outputable Unfolding where + 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 "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 "Cheap=") <> ppr cheap + , ptext (sLit "Expandable=") <> ppr exp + , ptext (sLit "Guidance=") <> ppr g ] + pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs + pp_rhs | isInlineRuleSource src = pp_tmpl + | otherwise = empty + -- Don't print the RHS or we get a quadratic + -- blowup in the size of the printout! \end{code} +----------------------------------------------------- +-- Rules +----------------------------------------------------- \begin{code} instance Outputable CoreRule where @@ -356,14 +426,14 @@ pprRules rules = vcat (map pprRule rules) pprRule :: CoreRule -> SDoc pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) - = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name) + = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name) pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) = hang (doubleQuotes (ftext name) <+> ppr act) - 4 (sep [ptext SLIT("forall") <+> braces (sep (map pprTypedBinder tpl_vars)), + 4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)), nest 2 (ppr fn <+> sep (map pprArg tpl_args)), - nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs) + nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) ]) \end{code}