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 <+> pprEqPred (coercionKind 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   = getPprStyle $ \ sty ->
 273     if debugStyle sty then
 274         parens (pprTypedBinder bndr)
 275     else
 276         if isDeadBinder bndr then char '_'
 277         else pprUntypedBinder bndr
 278
 279 pprUntypedBinder :: Var -> SDoc
 280 pprUntypedBinder binder
 281   | isTyVar binder = ptext (sLit "@") <+> ppr binder    -- NB: don't print kind
 282   | otherwise      = pprIdBndr binder
 283
 284 pprTypedBinder :: Var -> SDoc
 285 -- Print binder with a type or kind signature (not paren'd)
 286 pprTypedBinder binder
 287   | isTyVar binder  = pprKindedTyVarBndr binder
 288   | otherwise       = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 289
 290 pprKindedTyVarBndr :: TyVar -> SDoc
 291 -- Print a type variable binder with its kind (but not if *)
 292 pprKindedTyVarBndr tyvar
 293   = ptext (sLit "@") <+> ppr tyvar <> opt_kind
 294   where
 295     opt_kind    -- Print the kind if not *
 296         | isLiftedTypeKind kind = empty
 297         | otherwise = dcolon <> pprKind kind
 298     kind = tyVarKind tyvar
 299
 300 -- pprIdBndr does *not* print the type
 301 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 302 pprIdBndr :: Id -> SDoc
 303 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 304
 305 pprIdBndrInfo :: IdInfo -> SDoc
 306 pprIdBndrInfo info
 307   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
 308   where
 309     prag_info = inlinePragInfo info
 310     occ_info  = occInfo info
 311     dmd_info  = newDemandInfo info
 312     lbv_info  = lbvarInfo info
 313
 314     has_prag = not (isDefaultInlinePragma prag_info)
 315     has_occ  = not (isNoOcc occ_info)
 316     has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
 317     has_lbv  = not (hasNoLBVarInfo lbv_info)
 318
 319     doc = showAttributes
 320           [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
 321           , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
 322           , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
 323           , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
 324           ]
 325 \end{code}
 326
 327
 328 -----------------------------------------------------
 329 --      IdDetails and IdInfo
 330 -----------------------------------------------------
 331
 332 \begin{code}
 333 ppIdInfo :: Id -> IdInfo -> SDoc
 334 ppIdInfo id info
 335   = showAttributes
 336     [ (True, pp_scope <> ppr (idDetails id))
 337     , (has_arity,      ptext (sLit "Arity=") <> int arity)
 338     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
 339     , (has_strictness, ptext (sLit "Str=") <> pprNewStrictness str_info)
 340     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
 341     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
 342     ]   -- Inline pragma, occ, demand, lbvar info
 343         -- printed out with all binders (when debug is on);
 344         -- see PprCore.pprIdBndr
 345   where
 346     pp_scope | isGlobalId id   = ptext (sLit "GblId")
 347              | isExportedId id = ptext (sLit "LclIdX")
 348              | otherwise       = ptext (sLit "LclId")
 349
 350     arity = arityInfo info
 351     has_arity = arity /= 0
 352
 353     caf_info = cafInfo info
 354     has_caf_info = not (mayHaveCafRefs caf_info)
 355
 356     str_info = newStrictnessInfo info
 357     has_strictness = isJust str_info
 358
 359     unf_info = unfoldingInfo info
 360     has_unf = hasSomeUnfolding unf_info
 361
 362     rules = specInfoRules (specInfo info)
 363
 364 showAttributes :: [(Bool,SDoc)] -> SDoc
 365 showAttributes stuff
 366   | null docs = empty
 367   | otherwise = brackets (sep (punctuate comma docs))
 368   where
 369     docs = [d | (True,d) <- stuff]
 370 \end{code}
 371
 372 -----------------------------------------------------
 373 --      Unfolding and UnfoldingGuidance
 374 -----------------------------------------------------
 375
 376 \begin{code}
 377 instance Outputable UnfoldingGuidance where
 378     ppr UnfoldNever  = ptext (sLit "NEVER")
 379     ppr (InlineRule { ir_info = info, ir_sat = sat })
 380       = ptext (sLit "InlineRule") <> ppr (sat,info)
 381     ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
 382       = hsep [ ptext (sLit "IF_ARGS"),
 383                brackets (hsep (map int cs)),
 384                int size,
 385                int discount ]
 386
 387 instance Outputable InlSatFlag where
 388   ppr InlSat         = ptext (sLit "sat")
 389   ppr InlUnSat       = ptext (sLit "unsat")
 390
 391 instance Outputable InlineRuleInfo where
 392   ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
 393   ppr InlSmall       = ptext (sLit "small")
 394   ppr InlAlways      = ptext (sLit "always")
 395   ppr InlVanilla     = ptext (sLit "-")
 396
 397 instance Outputable Unfolding where
 398   ppr NoUnfolding             = ptext (sLit "No unfolding")
 399   ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs
 400   ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con
 401                                  <+> brackets (pprWithCommas pprParendExpr ops)
 402   ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
 403                      , uf_is_conlike=conlike, uf_is_cheap=cheap
 404                      , uf_expandable=exp, uf_guidance=g, uf_arity=arity})
 405         = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
 406     where
 407       pp_info = fsep $ punctuate comma
 408                 [ ptext (sLit "TopLvl=")     <> ppr top
 409                 , ptext (sLit "Arity=")      <> int arity
 410                 , ptext (sLit "Value=")      <> ppr hnf
 411                 , ptext (sLit "ConLike=")    <> ppr conlike
 412                 , ptext (sLit "Cheap=")      <> ppr cheap
 413                 , ptext (sLit "Expandable=") <> ppr exp
 414                 , ptext (sLit "Guidance=")   <> ppr g ]
 415       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
 416       pp_rhs = case g of
 417                   UnfoldNever         -> usually_empty
 418                   UnfoldIfGoodArgs {} -> usually_empty
 419                   _other              -> pp_tmpl
 420       usually_empty = ifPprDebug (ptext (sLit "<rhs>"))
 421             -- Don't print the RHS or we get a quadratic
 422             -- blowup in the size of the printout!
 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}