X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=c78516a1f7c7910245ec13ffa56fafca2f55c40e;hb=1e4f900ade324e2db2f886a11d7cb571ad5f180c;hp=950e37bc84cc049f5774f70e726cb28e80866798;hpb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;p=ghc-hetmet.git diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 950e37b..c78516a 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -152,11 +152,27 @@ ppr_expr add_par expr@(App {}) } ppr_expr add_par (Case expr var ty [(con,args,rhs)]) + | opt_PprCaseAsLet + = add_par $ + sep [sep [ ptext (sLit "let") + <+> char '{' + <+> ppr_case_pat con args + <+> ptext (sLit "~") + <+> ppr_bndr var + , ptext (sLit "<-") + <+> ppr_expr id expr + , char '}' + <+> ptext (sLit "in") + ] + , pprCoreExpr rhs + ] + + | otherwise = add_par $ sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, ifPprDebug (braces (ppr ty)), sep [ptext (sLit "of") <+> ppr_bndr var, - char '{' <+> ppr_case_pat con args] + char '{' <+> ppr_case_pat con args <+> arrow] ], pprCoreExpr rhs, char '}' @@ -218,23 +234,28 @@ ppr_expr add_par (Note (CoreNote s) expr) pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc pprCoreAlt (con, args, rhs) - = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs) + = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) 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 + = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) where ppr_bndr = pprBndr CaseBind tc = dataConTyCon dc ppr_case_pat con args - = ppr con <+> sep (map ppr_bndr args) <+> arrow + = ppr con <+> sep (map ppr_bndr args) where ppr_bndr = pprBndr CaseBind + +-- | Pretty print the argument in a function application. pprArg :: OutputableBndr a => Expr a -> SDoc -pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty +pprArg (Type ty) + | opt_SuppressTypeApplications = empty + | otherwise = ptext (sLit "@") <+> pprParendType ty + pprArg expr = pprParendExpr expr \end{code} @@ -247,40 +268,39 @@ instance OutputableBndr Var where 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 - = 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 +pprCoreBinder bind_site 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 - | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) + | isTyCoVar binder = pprKindedTyVarBndr binder + | opt_SuppressTypeSignatures = empty + | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) @@ -299,6 +319,8 @@ pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) pprIdBndrInfo :: IdInfo -> SDoc pprIdBndrInfo info + | opt_SuppressIdInfo = empty + | otherwise = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes where prag_info = inlinePragInfo info @@ -327,6 +349,8 @@ pprIdBndrInfo info \begin{code} ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo id info + | opt_SuppressIdInfo = empty + | otherwise = showAttributes [ (True, pp_scope <> ppr (idDetails id)) , (has_arity, ptext (sLit "Arity=") <> int arity) @@ -370,37 +394,38 @@ showAttributes stuff \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 "") 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 @@ -408,11 +433,8 @@ instance Outputable Unfolding where , 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 "")) + 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}