compiler/coreSyn/PprCore.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1996-1998
   4 %
   5
   6 Printing of Core syntax
   7
   8 \begin{code}
   9 module PprCore (
  10         pprCoreExpr, pprParendExpr,
  11         pprCoreBinding, pprCoreBindings, pprCoreAlt,
  12         pprRules
  13     ) where
  14
  15 import CoreSyn
  16 import CostCentre
  17 import Var
  18 import Id
  19 import IdInfo
  20 import NewDemand
  21 #ifdef OLD_STRICTNESS
  22 import Id
  23 import IdInfo
  24 #endif
  25
  26 import DataCon
  27 import TyCon
  28 import Type
  29 import Coercion
  30 import StaticFlags
  31 import BasicTypes
  32 import Util
  33 import Outputable
  34 import FastString
  35 import Data.Maybe
  36 \end{code}
  37
  38 %************************************************************************
  39 %*                                                                      *
  40 \subsection{Public interfaces for Core printing (excluding instances)}
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  45
  46 \begin{code}
  47 pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
  48 pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc
  49 pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc
  50 pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc
  51
  52 pprCoreBindings = pprTopBinds
  53 pprCoreBinding  = pprTopBind
  54
  55 instance OutputableBndr b => Outputable (Bind b) where
  56     ppr bind = ppr_bind bind
  57
  58 instance OutputableBndr b => Outputable (Expr b) where
  59     ppr expr = pprCoreExpr expr
  60 \end{code}
  61
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection{The guts}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc
  71 pprTopBinds binds = vcat (map pprTopBind binds)
  72
  73 pprTopBind :: OutputableBndr a => Bind a -> SDoc
  74 pprTopBind (NonRec binder expr)
  75  = ppr_binding (binder,expr) $$ blankLine
  76
  77 pprTopBind (Rec [])
  78   = ptext (sLit "Rec { }")
  79 pprTopBind (Rec (b:bs))
  80   = vcat [ptext (sLit "Rec {"),
  81           ppr_binding b,
  82           vcat [blankLine $$ ppr_binding b | b <- bs],
  83           ptext (sLit "end Rec }"),
  84           blankLine]
  85 \end{code}
  86
  87 \begin{code}
  88 ppr_bind :: OutputableBndr b => Bind b -> SDoc
  89
  90 ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
  91 ppr_bind (Rec binds)           = vcat (map pp binds)
  92                                where
  93                                  pp bind = ppr_binding bind <> semi
  94
  95 ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
  96 ppr_binding (val_bdr, expr)
  97   = pprBndr LetBind val_bdr $$
  98     hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
  99 \end{code}
 100
 101 \begin{code}
 102 pprParendExpr   expr = ppr_expr parens expr
 103 pprCoreExpr expr = ppr_expr noParens expr
 104
 105 noParens :: SDoc -> SDoc
 106 noParens pp = pp
 107 \end{code}
 108
 109 \begin{code}
 110 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
 111         -- The function adds parens in context that need
 112         -- an atomic value (e.g. function args)
 113
 114 ppr_expr add_par (Type ty)  = add_par (ptext (sLit "TYPE") <+> ppr ty)  -- Wierd
 115
 116 ppr_expr _       (Var name) = ppr name
 117 ppr_expr _       (Lit lit)  = ppr lit
 118
 119 ppr_expr add_par (Cast expr co)
 120   = add_par $
 121     sep [pprParendExpr expr,
 122          ptext (sLit "`cast`") <+> pprCo co]
 123   where
 124     pprCo co | opt_SuppressCoercions = ptext (sLit "...")
 125              | otherwise = parens
 126                          $ sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)]
 127
 128
 129 ppr_expr add_par expr@(Lam _ _)
 130   = let
 131         (bndrs, body) = collectBinders expr
 132     in
 133     add_par $
 134     hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
 135          2 (pprCoreExpr body)
 136
 137 ppr_expr add_par expr@(App {})
 138   = case collectArgs expr of { (fun, args) ->
 139     let
 140         pp_args     = sep (map pprArg args)
 141         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
 142         pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
 143     in
 144     case fun of
 145         Var f -> case isDataConWorkId_maybe f of
 146                         -- Notice that we print the *worker*
 147                         -- for tuples in paren'd format.
 148                    Just dc | saturated && isTupleTyCon tc
 149                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
 150                            where
 151                              tc        = dataConTyCon dc
 152                              saturated = val_args `lengthIs` idArity f
 153
 154                    _ -> add_par (hang (ppr f) 2 pp_args)
 155
 156         _ -> add_par (hang (pprParendExpr fun) 2 pp_args)
 157     }
 158
 159 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
 160   = add_par $
 161     sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
 162               ifPprDebug (braces (ppr ty)),
 163               sep [ptext (sLit "of") <+> ppr_bndr var,
 164                    char '{' <+> ppr_case_pat con args]
 165           ],
 166          pprCoreExpr rhs,
 167          char '}'
 168     ]
 169   where
 170     ppr_bndr = pprBndr CaseBind
 171
 172 ppr_expr add_par (Case expr var ty alts)
 173   = add_par $
 174     sep [sep [ptext (sLit "case")
 175                 <+> pprCoreExpr expr
 176                 <+> ifPprDebug (braces (ppr ty)),
 177               ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
 178          nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
 179          char '}'
 180     ]
 181   where
 182     ppr_bndr = pprBndr CaseBind
 183
 184
 185 -- special cases: let ... in let ...
 186 -- ("disgusting" SLPJ)
 187
 188 {-
 189 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 190   = add_par $
 191     vcat [
 192       hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
 193       nest 2 (pprCoreExpr rhs),
 194       ptext (sLit "} in"),
 195       pprCoreExpr body ]
 196
 197 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 198   = add_par
 199     (hang (ptext (sLit "let {"))
 200           2 (hsep [ppr_binding (val_bdr,rhs),
 201                    ptext (sLit "} in")])
 202      $$
 203      pprCoreExpr expr)
 204 -}
 205
 206 -- General case (recursive case, too)
 207 ppr_expr add_par (Let bind expr)
 208   = add_par $
 209     sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")),
 210          pprCoreExpr expr]
 211   where
 212     keyword = case bind of
 213                 Rec _      -> (sLit "letrec {")
 214                 NonRec _ _ -> (sLit "let {")
 215
 216 ppr_expr add_par (Note (SCC cc) expr)
 217   = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
 218
 219 ppr_expr add_par (Note (CoreNote s) expr)
 220   = add_par $
 221     sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
 222          pprParendExpr expr]
 223
 224 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
 225 pprCoreAlt (con, args, rhs)
 226   = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
 227
 228 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
 229 ppr_case_pat (DataAlt dc) args
 230   | isTupleTyCon tc
 231   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
 232   where
 233     ppr_bndr = pprBndr CaseBind
 234     tc = dataConTyCon dc
 235
 236 ppr_case_pat con args
 237   = ppr con <+> sep (map ppr_bndr args) <+> arrow
 238   where
 239     ppr_bndr = pprBndr CaseBind
 240
 241 pprArg :: OutputableBndr a => Expr a -> SDoc
 242 pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty
 243 pprArg expr      = pprParendExpr expr
 244 \end{code}
 245
 246 Other printing bits-and-bobs used with the general @pprCoreBinding@
 247 and @pprCoreExpr@ functions.
 248
 249 \begin{code}
 250 instance OutputableBndr Var where
 251   pprBndr = pprCoreBinder
 252
 253 pprCoreBinder :: BindingSite -> Var -> SDoc
 254 pprCoreBinder LetBind binder
 255   | isTyVar binder = pprKindedTyVarBndr binder
 256   | otherwise      = pprTypedBinder binder $$
 257                      ppIdInfo binder (idInfo binder)
 258
 259 -- Lambda bound type variables are preceded by "@"
 260 pprCoreBinder LambdaBind bndr
 261   | isDeadBinder bndr
 262   = getPprStyle $ \ sty ->
 263     if debugStyle sty then
 264         parens (pprTypedBinder bndr)
 265     else
 266         char '_'
 267   | otherwise
 268   = parens (pprTypedBinder bndr)
 269
 270 -- Case bound things don't get a signature or a herald, unless we have debug on
 271 pprCoreBinder CaseBind bndr
 272   | isDeadBinder bndr    -- False for tyvars
 273   = ptext (sLit "_")
 274   | otherwise
 275   = getPprStyle $ \ sty ->
 276     if debugStyle sty then
 277         parens (pprTypedBinder bndr)
 278     else
 279         if isDeadBinder bndr then char '_'
 280         else pprUntypedBinder bndr
 281
 282 pprUntypedBinder :: Var -> SDoc
 283 pprUntypedBinder binder
 284   | isTyVar binder = ptext (sLit "@") <+> ppr binder    -- NB: don't print kind
 285   | otherwise      = pprIdBndr binder
 286
 287 pprTypedBinder :: Var -> SDoc
 288 -- Print binder with a type or kind signature (not paren'd)
 289 pprTypedBinder binder
 290   | isTyVar binder  = pprKindedTyVarBndr binder
 291   | otherwise       = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 292
 293 pprKindedTyVarBndr :: TyVar -> SDoc
 294 -- Print a type variable binder with its kind (but not if *)
 295 pprKindedTyVarBndr tyvar
 296   = ptext (sLit "@") <+> ppr tyvar <> opt_kind
 297   where
 298     opt_kind    -- Print the kind if not *
 299         | isLiftedTypeKind kind = empty
 300         | otherwise = dcolon <> pprKind kind
 301     kind = tyVarKind tyvar
 302
 303 -- pprIdBndr does *not* print the type
 304 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 305 pprIdBndr :: Id -> SDoc
 306 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 307
 308 pprIdBndrInfo :: IdInfo -> SDoc
 309 pprIdBndrInfo info
 310   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
 311   where
 312     prag_info = inlinePragInfo info
 313     occ_info  = occInfo info
 314     dmd_info  = newDemandInfo info
 315     lbv_info  = lbvarInfo info
 316
 317     has_prag = not (isDefaultInlinePragma prag_info)
 318     has_occ  = not (isNoOcc occ_info)
 319     has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
 320     has_lbv  = not (hasNoLBVarInfo lbv_info)
 321
 322     doc = showAttributes
 323           [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
 324           , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
 325           , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
 326           , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
 327           ]
 328 \end{code}
 329
 330
 331 -----------------------------------------------------
 332 --      IdDetails and IdInfo
 333 -----------------------------------------------------
 334
 335 \begin{code}
 336 ppIdInfo :: Id -> IdInfo -> SDoc
 337 ppIdInfo id info
 338   = showAttributes
 339     [ (True, pp_scope <> ppr (idDetails id))
 340     , (has_arity,      ptext (sLit "Arity=") <> int arity)
 341     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
 342     , (has_strictness, ptext (sLit "Str=") <> pprNewStrictness str_info)
 343     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
 344     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
 345     ]   -- Inline pragma, occ, demand, lbvar info
 346         -- printed out with all binders (when debug is on);
 347         -- see PprCore.pprIdBndr
 348   where
 349     pp_scope | isGlobalId id   = ptext (sLit "GblId")
 350              | isExportedId id = ptext (sLit "LclIdX")
 351              | otherwise       = ptext (sLit "LclId")
 352
 353     arity = arityInfo info
 354     has_arity = arity /= 0
 355
 356     caf_info = cafInfo info
 357     has_caf_info = not (mayHaveCafRefs caf_info)
 358
 359     str_info = newStrictnessInfo info
 360     has_strictness = isJust str_info
 361
 362     unf_info = unfoldingInfo info
 363     has_unf = hasSomeUnfolding unf_info
 364
 365     rules = specInfoRules (specInfo info)
 366
 367 showAttributes :: [(Bool,SDoc)] -> SDoc
 368 showAttributes stuff
 369   | null docs = empty
 370   | otherwise = brackets (sep (punctuate comma docs))
 371   where
 372     docs = [d | (True,d) <- stuff]
 373 \end{code}
 374
 375 -----------------------------------------------------
 376 --      Unfolding and UnfoldingGuidance
 377 -----------------------------------------------------
 378
 379 \begin{code}
 380 instance Outputable UnfoldingGuidance where
 381     ppr UnfoldNever  = ptext (sLit "NEVER")
 382     ppr (InlineRule { ir_info = info, ir_sat = sat })
 383       = ptext (sLit "InlineRule") <> ppr (sat,info)
 384     ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
 385       = hsep [ ptext (sLit "IF_ARGS"),
 386                brackets (hsep (map int cs)),
 387                int size,
 388                int discount ]
 389
 390 instance Outputable InlSatFlag where
 391   ppr InlSat         = ptext (sLit "sat")
 392   ppr InlUnSat       = ptext (sLit "unsat")
 393
 394 instance Outputable InlineRuleInfo where
 395   ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
 396   ppr InlSmall       = ptext (sLit "small")
 397   ppr InlAlways      = ptext (sLit "always")
 398   ppr InlVanilla     = ptext (sLit "-")
 399
 400 instance Outputable Unfolding where
 401   ppr NoUnfolding             = ptext (sLit "No unfolding")
 402   ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs
 403   ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con
 404                                  <+> brackets (pprWithCommas pprParendExpr ops)
 405   ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
 406                      , uf_is_conlike=conlike, uf_is_cheap=cheap
 407                      , uf_expandable=exp, uf_guidance=g, uf_arity=arity})
 408         = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
 409     where
 410       pp_info = hsep [ ptext (sLit "TopLvl=") <> ppr top
 411                      , ptext (sLit "Arity=") <> int arity
 412                      , ptext (sLit "Value=") <> ppr hnf
 413                      , ptext (sLit "ConLike=") <> ppr conlike
 414                      , ptext (sLit "Cheap=") <> ppr cheap
 415                      , ptext (sLit "Expandable=") <> ppr exp
 416                      , ppr g ]
 417       pp_rhs = case g of
 418                   UnfoldNever         -> usually_empty
 419                   UnfoldIfGoodArgs {} -> usually_empty
 420                   _other              -> ppr rhs
 421       usually_empty = ifPprDebug (ppr rhs)
 422             -- In this case show 'rhs' only in debug mode
 423 \end{code}
 424
 425 -----------------------------------------------------
 426 --      Rules
 427 -----------------------------------------------------
 428
 429 \begin{code}
 430 instance Outputable CoreRule where
 431    ppr = pprRule
 432
 433 pprRules :: [CoreRule] -> SDoc
 434 pprRules rules = vcat (map pprRule rules)
 435
 436 pprRule :: CoreRule -> SDoc
 437 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
 438   = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
 439
 440 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
 441                 ru_bndrs = tpl_vars, ru_args = tpl_args,
 442                 ru_rhs = rhs })
 443   = hang (doubleQuotes (ftext name) <+> ppr act)
 444        4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 445                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
 446                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
 447             ])
 448 \end{code}