X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=1908667e1473f0fad80854433dafaf8e738c2693;hp=9213e9cd54342771da0af414965bf231fcb27d0f;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=c01e472e205f09e6cdadc1c878263998f637bc8d diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 9213e9c..1908667 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -17,12 +17,7 @@ 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 @@ -123,7 +118,7 @@ ppr_expr add_par (Cast expr co) where pprCo co | opt_SuppressCoercions = ptext (sLit "...") | otherwise = parens - $ sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)] + $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] ppr_expr add_par expr@(Lam _ _) @@ -252,42 +247,37 @@ 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 +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 - | isDeadBinder bndr -- False for tyvars - = ptext (sLit "_") - | otherwise - = 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 @@ -311,7 +301,7 @@ pprIdBndrInfo info where prag_info = inlinePragInfo info occ_info = occInfo info - dmd_info = newDemandInfo info + dmd_info = demandInfo info lbv_info = lbvarInfo info has_prag = not (isDefaultInlinePragma prag_info) @@ -339,7 +329,7 @@ ppIdInfo id info [ (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=") <> pprNewStrictness str_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 @@ -356,7 +346,7 @@ ppIdInfo id info caf_info = cafInfo info has_caf_info = not (mayHaveCafRefs caf_info) - str_info = newStrictnessInfo info + str_info = strictnessInfo info has_strictness = isJust str_info unf_info = unfoldingInfo info @@ -378,44 +368,49 @@ showAttributes stuff \begin{code} instance Outputable UnfoldingGuidance where - ppr UnfoldNever = ptext (sLit "NEVER") - ppr UnfoldAlways = ptext (sLit "ALWAYS") - ppr (InlineRule { ug_ir_info = inl_info, ug_small = small }) - = ptext (sLit "InlineRule") <> ppr (inl_info,small) - 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 InlineRuleInfo where - ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w - ppr InlSat = ptext (sLit "sat") - ppr InlUnSat = ptext (sLit "unsat") +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 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 = hsep [ 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 - , ppr g ] - pp_rhs = case g of - UnfoldNever -> usually_empty - UnfoldIfGoodArgs {} -> usually_empty - _other -> ppr rhs - usually_empty = ifPprDebug (ppr rhs) - -- In this case show 'rhs' only in debug mode + 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} -----------------------------------------------------