% % (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1996-1998 % Printing of Core syntax \begin{code} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details module PprCore ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprCoreAlt, pprRules ) where import CoreSyn import Literal( pprLiteral ) import Name( pprInfixName, pprPrefixName ) import Var import Id import IdInfo import Demand import DataCon import TyCon import Type import Kind import Coercion import StaticFlags import BasicTypes import Util import Outputable import FastString import Data.Maybe \end{code} %************************************************************************ %* * \subsection{Public interfaces for Core printing (excluding instances)} %* * %************************************************************************ @pprParendCoreExpr@ puts parens around non-atomic Core expressions. \begin{code} pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc pprCoreBinding :: OutputableBndr b => Bind b -> SDoc pprCoreExpr :: OutputableBndr b => Expr b -> SDoc pprParendExpr :: OutputableBndr b => Expr b -> SDoc pprCoreBindings = pprTopBinds pprCoreBinding = pprTopBind instance OutputableBndr b => Outputable (Bind b) where ppr bind = ppr_bind bind instance OutputableBndr b => Outputable (Expr b) where ppr expr = pprCoreExpr expr \end{code} %************************************************************************ %* * \subsection{The guts} %* * %************************************************************************ \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) $$ 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} ppr_bind :: OutputableBndr b => Bind b -> SDoc ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr) ppr_bind (Rec binds) = vcat (map pp binds) where pp bind = ppr_binding bind <> semi ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc ppr_binding (val_bdr, expr) = pprBndr LetBind val_bdr $$ hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr) \end{code} \begin{code} pprParendExpr expr = ppr_expr parens expr pprCoreExpr expr = ppr_expr noParens expr noParens :: SDoc -> SDoc noParens pp = pp \end{code} \begin{code} 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 _ (Var name) = ppr name ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co) ppr_expr add_par (Lit lit) = pprLiteral add_par lit ppr_expr add_par (Cast expr co) = add_par $ sep [pprParendExpr expr, ptext (sLit "`cast`") <+> pprCo co] where pprCo co | opt_SuppressCoercions = ptext (sLit "...") | otherwise = parens $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] ppr_expr add_par expr@(Lam _ _) = let (bndrs, body) = collectBinders expr in add_par $ hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) 2 (pprCoreExpr body) ppr_expr add_par expr@(App {}) = case collectArgs expr of { (fun, args) -> let pp_args = sep (map pprArg args) val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args)) in case fun of Var f -> case isDataConWorkId_maybe f of -- Notice that we print the *worker* -- for tuples in paren'd format. Just dc | saturated && isTupleTyCon tc -> tupleParens (tupleTyConSort tc) pp_tup_args where tc = dataConTyCon dc saturated = val_args `lengthIs` idArity f _ -> add_par (hang (ppr f) 2 pp_args) _ -> add_par (hang (pprParendExpr fun) 2 pp_args) } 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 <+> arrow] ], pprCoreExpr rhs, char '}' ] where ppr_bndr = pprBndr CaseBind ppr_expr add_par (Case expr var ty alts) = add_par $ sep [sep [ptext (sLit "case") <+> pprCoreExpr expr <+> ifPprDebug (braces (ppr ty)), ptext (sLit "of") <+> ppr_bndr var <+> char '{'], nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), char '}' ] where ppr_bndr = pprBndr CaseBind -- special cases: let ... in let ... -- ("disgusting" SLPJ) {- 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], nest 2 (pprCoreExpr rhs), ptext (sLit "} in"), pprCoreExpr body ] ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = add_par (hang (ptext (sLit "let {")) 2 (hsep [ppr_binding (val_bdr,rhs), ptext (sLit "} in")]) $$ pprCoreExpr expr) -} -- General case (recursive case, too) ppr_expr add_par (Let bind expr) = add_par $ sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")), pprCoreExpr expr] where keyword = case bind of Rec _ -> (sLit "letrec {") NonRec _ _ -> (sLit "let {") ppr_expr add_par (Tick tickish expr) = add_par (sep [ppr tickish, pprCoreExpr expr]) pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc pprCoreAlt (con, args, 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 (tupleTyConSort 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) where ppr_bndr = pprBndr CaseBind -- | Pretty print the argument in a function application. pprArg :: OutputableBndr a => Expr a -> SDoc pprArg (Type ty) | opt_SuppressTypeApplications = empty | otherwise = ptext (sLit "@") <+> pprParendType ty pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co pprArg expr = pprParendExpr expr \end{code} Other printing bits-and-bobs used with the general @pprCoreBinding@ and @pprCoreExpr@ functions. \begin{code} instance OutputableBndr Var where pprBndr = pprCoreBinder pprInfixOcc = pprInfixName . varName pprPrefixOcc = pprPrefixName . varName pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder | isTyVar binder = pprKindedTyVarBndr binder | otherwise = pprTypedLetBinder binder $$ ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder bind_site bndr = getPprStyle $ \ sty -> pprTypedLamBinder bind_site (debugStyle sty) bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc -- For lambda and case binders, show the unfolding info (usually none) pprTypedLamBinder bind_site debug_on var | not debug_on && isDeadBinder var = char '_' | not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info | opt_SuppressAll = pprUntypedBinder var -- Suppress the signature | isTyVar 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 pprTypedLetBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) pprTypedLetBinder binder | isTyVar binder = pprKindedTyVarBndr binder | opt_SuppressTypeSignatures = pprIdBndr binder | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) 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 | opt_SuppressIdInfo = empty | otherwise = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes where prag_info = inlinePragInfo info occ_info = occInfo info dmd_info = demandInfo info lbv_info = lbvarInfo info 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} ----------------------------------------------------- -- IdDetails and IdInfo ----------------------------------------------------- \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) , (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 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 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 ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar) <+> ppr con <+> brackets (pprWithCommas ppr 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 | 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} ----------------------------------------------------- -- Rules ----------------------------------------------------- \begin{code} instance Outputable CoreRule where ppr = pprRule pprRules :: [CoreRule] -> SDoc 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) 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") <+> sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, nest 2 (ppr fn <+> sep (map pprArg tpl_args)), nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) ]) \end{code} ----------------------------------------------------- -- Tickish ----------------------------------------------------- \begin{code} instance Outputable id => Outputable (Tickish id) where ppr (HpcTick modl ix) = hcat [ptext (sLit "tick<"), ppr modl, comma, ppr ix, ptext (sLit ">")] ppr (Breakpoint ix vars) = hcat [ptext (sLit "break<"), ppr ix, ptext (sLit ">"), parens (hcat (punctuate comma (map ppr vars)))] ppr (ProfNote { profNoteCC = cc, profNoteCount = tick, profNoteScope = scope }) = case (tick,scope) of (True,True) -> hcat [ptext (sLit "scctick<"), ppr cc, char '>'] (True,False) -> hcat [ptext (sLit "tick<"), ppr cc, char '>'] _ -> hcat [ptext (sLit "scc<"), ppr cc, char '>'] \end{code} ----------------------------------------------------- -- Vectorisation declarations ----------------------------------------------------- \begin{code} instance Outputable CoreVect where ppr (Vect var Nothing) = ptext (sLit "VECTORISE SCALAR") <+> ppr var ppr (Vect var (Just e)) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=') 4 (pprCoreExpr e) ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var ppr (VectType False var Nothing) = ptext (sLit "VECTORISE type") <+> ppr var ppr (VectType True var Nothing) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+> ppr tc ppr (VectType True var (Just tc)) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+> char '=' <+> ppr tc ppr (VectClass tc) = ptext (sLit "VECTORISE class") <+> ppr tc ppr (VectInst var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var \end{code}