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 Demand
  21 import DataCon
  22 import TyCon
  23 import Type
  24 import Coercion
  25 import StaticFlags
  26 import BasicTypes
  27 import Util
  28 import Outputable
  29 import FastString
  30 import Data.Maybe
  31 \end{code}
  32
  33 %************************************************************************
  34 %*                                                                      *
  35 \subsection{Public interfaces for Core printing (excluding instances)}
  36 %*                                                                      *
  37 %************************************************************************
  38
  39 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  40
  41 \begin{code}
  42 pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
  43 pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc
  44 pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc
  45 pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc
  46
  47 pprCoreBindings = pprTopBinds
  48 pprCoreBinding  = pprTopBind
  49
  50 instance OutputableBndr b => Outputable (Bind b) where
  51     ppr bind = ppr_bind bind
  52
  53 instance OutputableBndr b => Outputable (Expr b) where
  54     ppr expr = pprCoreExpr expr
  55 \end{code}
  56
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{The guts}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65 pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc
  66 pprTopBinds binds = vcat (map pprTopBind binds)
  67
  68 pprTopBind :: OutputableBndr a => Bind a -> SDoc
  69 pprTopBind (NonRec binder expr)
  70  = ppr_binding (binder,expr) $$ blankLine
  71
  72 pprTopBind (Rec [])
  73   = ptext (sLit "Rec { }")
  74 pprTopBind (Rec (b:bs))
  75   = vcat [ptext (sLit "Rec {"),
  76           ppr_binding b,
  77           vcat [blankLine $$ ppr_binding b | b <- bs],
  78           ptext (sLit "end Rec }"),
  79           blankLine]
  80 \end{code}
  81
  82 \begin{code}
  83 ppr_bind :: OutputableBndr b => Bind b -> SDoc
  84
  85 ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
  86 ppr_bind (Rec binds)           = vcat (map pp binds)
  87                                where
  88                                  pp bind = ppr_binding bind <> semi
  89
  90 ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
  91 ppr_binding (val_bdr, expr)
  92   = pprBndr LetBind val_bdr $$
  93     hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
  94 \end{code}
  95
  96 \begin{code}
  97 pprParendExpr   expr = ppr_expr parens expr
  98 pprCoreExpr expr = ppr_expr noParens expr
  99
 100 noParens :: SDoc -> SDoc
 101 noParens pp = pp
 102 \end{code}
 103
 104 \begin{code}
 105 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
 106         -- The function adds parens in context that need
 107         -- an atomic value (e.g. function args)
 108
 109 ppr_expr add_par (Type ty)  = add_par (ptext (sLit "TYPE") <+> ppr ty)  -- Wierd
 110
 111 ppr_expr _       (Var name) = ppr name
 112 ppr_expr _       (Lit lit)  = ppr lit
 113
 114 ppr_expr add_par (Cast expr co)
 115   = add_par $
 116     sep [pprParendExpr expr,
 117          ptext (sLit "`cast`") <+> pprCo co]
 118   where
 119     pprCo co | opt_SuppressCoercions = ptext (sLit "...")
 120              | otherwise = parens
 121                          $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
 122
 123
 124 ppr_expr add_par expr@(Lam _ _)
 125   = let
 126         (bndrs, body) = collectBinders expr
 127     in
 128     add_par $
 129     hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
 130          2 (pprCoreExpr body)
 131
 132 ppr_expr add_par expr@(App {})
 133   = case collectArgs expr of { (fun, args) ->
 134     let
 135         pp_args     = sep (map pprArg args)
 136         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
 137         pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
 138     in
 139     case fun of
 140         Var f -> case isDataConWorkId_maybe f of
 141                         -- Notice that we print the *worker*
 142                         -- for tuples in paren'd format.
 143                    Just dc | saturated && isTupleTyCon tc
 144                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
 145                            where
 146                              tc        = dataConTyCon dc
 147                              saturated = val_args `lengthIs` idArity f
 148
 149                    _ -> add_par (hang (ppr f) 2 pp_args)
 150
 151         _ -> add_par (hang (pprParendExpr fun) 2 pp_args)
 152     }
 153
 154 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
 155   = add_par $
 156     sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
 157               ifPprDebug (braces (ppr ty)),
 158               sep [ptext (sLit "of") <+> ppr_bndr var,
 159                    char '{' <+> ppr_case_pat con args]
 160           ],
 161          pprCoreExpr rhs,
 162          char '}'
 163     ]
 164   where
 165     ppr_bndr = pprBndr CaseBind
 166
 167 ppr_expr add_par (Case expr var ty alts)
 168   = add_par $
 169     sep [sep [ptext (sLit "case")
 170                 <+> pprCoreExpr expr
 171                 <+> ifPprDebug (braces (ppr ty)),
 172               ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
 173          nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
 174          char '}'
 175     ]
 176   where
 177     ppr_bndr = pprBndr CaseBind
 178
 179
 180 -- special cases: let ... in let ...
 181 -- ("disgusting" SLPJ)
 182
 183 {-
 184 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 185   = add_par $
 186     vcat [
 187       hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
 188       nest 2 (pprCoreExpr rhs),
 189       ptext (sLit "} in"),
 190       pprCoreExpr body ]
 191
 192 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 193   = add_par
 194     (hang (ptext (sLit "let {"))
 195           2 (hsep [ppr_binding (val_bdr,rhs),
 196                    ptext (sLit "} in")])
 197      $$
 198      pprCoreExpr expr)
 199 -}
 200
 201 -- General case (recursive case, too)
 202 ppr_expr add_par (Let bind expr)
 203   = add_par $
 204     sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")),
 205          pprCoreExpr expr]
 206   where
 207     keyword = case bind of
 208                 Rec _      -> (sLit "letrec {")
 209                 NonRec _ _ -> (sLit "let {")
 210
 211 ppr_expr add_par (Note (SCC cc) expr)
 212   = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
 213
 214 ppr_expr add_par (Note (CoreNote s) expr)
 215   = add_par $
 216     sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
 217          pprParendExpr expr]
 218
 219 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
 220 pprCoreAlt (con, args, rhs)
 221   = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
 222
 223 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
 224 ppr_case_pat (DataAlt dc) args
 225   | isTupleTyCon tc
 226   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
 227   where
 228     ppr_bndr = pprBndr CaseBind
 229     tc = dataConTyCon dc
 230
 231 ppr_case_pat con args
 232   = ppr con <+> sep (map ppr_bndr args) <+> arrow
 233   where
 234     ppr_bndr = pprBndr CaseBind
 235
 236
 237 -- | Pretty print the argument in a function application.
 238 pprArg :: OutputableBndr a => Expr a -> SDoc
 239 pprArg (Type ty)
 240  | opt_SuppressTypeApplications = empty
 241  | otherwise                    = ptext (sLit "@") <+> pprParendType ty
 242
 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   | isTyCoVar binder = pprKindedTyVarBndr binder
 256   | otherwise      = pprTypedBinder binder $$
 257                      ppIdInfo binder (idInfo binder)
 258
 259 -- Lambda bound type variables are preceded by "@"
 260 pprCoreBinder bind_site bndr
 261   = getPprStyle $ \ sty ->
 262     pprTypedLCBinder bind_site (debugStyle sty) bndr
 263
 264 pprUntypedBinder :: Var -> SDoc
 265 pprUntypedBinder binder
 266   | isTyCoVar binder = ptext (sLit "@") <+> ppr binder  -- NB: don't print kind
 267   | otherwise      = pprIdBndr binder
 268
 269 pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
 270 -- For lambda and case binders, show the unfolding info (usually none)
 271 pprTypedLCBinder bind_site debug_on var
 272   | not debug_on && isDeadBinder var    = char '_'
 273   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
 274   | isTyCoVar var                         = parens (pprKindedTyVarBndr var)
 275   | otherwise = parens (hang (pprIdBndr var)
 276                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
 277               where
 278                 unf_info = unfoldingInfo (idInfo var)
 279                 pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
 280                        | otherwise                 = empty
 281
 282 pprTypedBinder :: Var -> SDoc
 283 -- Print binder with a type or kind signature (not paren'd)
 284 pprTypedBinder binder
 285   | isTyCoVar binder            = pprKindedTyVarBndr binder
 286   | opt_SuppressTypeSignatures  = empty
 287   | otherwise                   = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 288
 289 pprKindedTyVarBndr :: TyVar -> SDoc
 290 -- Print a type variable binder with its kind (but not if *)
 291 pprKindedTyVarBndr tyvar
 292   = ptext (sLit "@") <+> ppr tyvar <> opt_kind
 293   where
 294     opt_kind    -- Print the kind if not *
 295         | isLiftedTypeKind kind = empty
 296         | otherwise = dcolon <> pprKind kind
 297     kind = tyVarKind tyvar
 298
 299 -- pprIdBndr does *not* print the type
 300 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 301 pprIdBndr :: Id -> SDoc
 302 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 303
 304 pprIdBndrInfo :: IdInfo -> SDoc
 305 pprIdBndrInfo info
 306   | opt_SuppressIdInfo = empty
 307   | otherwise
 308   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
 309   where
 310     prag_info = inlinePragInfo info
 311     occ_info  = occInfo info
 312     dmd_info  = demandInfo info
 313     lbv_info  = lbvarInfo info
 314
 315     has_prag = not (isDefaultInlinePragma prag_info)
 316     has_occ  = not (isNoOcc occ_info)
 317     has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
 318     has_lbv  = not (hasNoLBVarInfo lbv_info)
 319
 320     doc = showAttributes
 321           [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
 322           , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
 323           , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
 324           , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
 325           ]
 326 \end{code}
 327
 328
 329 -----------------------------------------------------
 330 --      IdDetails and IdInfo
 331 -----------------------------------------------------
 332
 333 \begin{code}
 334 ppIdInfo :: Id -> IdInfo -> SDoc
 335 ppIdInfo id info
 336   | opt_SuppressIdInfo  = empty
 337   | otherwise
 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=") <> pprStrictness 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 = strictnessInfo 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 UnfNever  = ptext (sLit "NEVER")
 382     ppr (UnfWhen unsat_ok boring_ok)
 383       = ptext (sLit "ALWAYS_IF") <>
 384         parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
 385                 ptext (sLit "boring_ok=") <> ppr boring_ok)
 386     ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
 387       = hsep [ ptext (sLit "IF_ARGS"),
 388                brackets (hsep (map int cs)),
 389                int size,
 390                int discount ]
 391
 392 instance Outputable UnfoldingSource where
 393   ppr InlineCompulsory  = ptext (sLit "Compulsory")
 394   ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
 395   ppr InlineStable      = ptext (sLit "InlineStable")
 396   ppr InlineRhs         = ptext (sLit "<vanilla>")
 397
 398 instance Outputable Unfolding where
 399   ppr NoUnfolding                = ptext (sLit "No unfolding")
 400   ppr (OtherCon cs)              = ptext (sLit "OtherCon") <+> ppr cs
 401   ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
 402                                    <+> ppr con
 403                                    <+> brackets (pprWithCommas pprParendExpr ops)
 404   ppr (CoreUnfolding { uf_src = src
 405                      , 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 = fsep $ punctuate comma
 411                 [ ptext (sLit "Src=")        <> ppr src
 412                 , ptext (sLit "TopLvl=")     <> ppr top
 413                 , ptext (sLit "Arity=")      <> int arity
 414                 , ptext (sLit "Value=")      <> ppr hnf
 415                 , ptext (sLit "ConLike=")    <> ppr conlike
 416                 , ptext (sLit "Cheap=")      <> ppr cheap
 417                 , ptext (sLit "Expandable=") <> ppr exp
 418                 , ptext (sLit "Guidance=")   <> ppr g ]
 419       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
 420       pp_rhs | isStableSource src = pp_tmpl
 421              | otherwise          = empty
 422             -- Don't print the RHS or we get a quadratic
 423             -- blowup in the size of the printout!
 424 \end{code}
 425
 426 -----------------------------------------------------
 427 --      Rules
 428 -----------------------------------------------------
 429
 430 \begin{code}
 431 instance Outputable CoreRule where
 432    ppr = pprRule
 433
 434 pprRules :: [CoreRule] -> SDoc
 435 pprRules rules = vcat (map pprRule rules)
 436
 437 pprRule :: CoreRule -> SDoc
 438 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
 439   = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
 440
 441 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
 442                 ru_bndrs = tpl_vars, ru_args = tpl_args,
 443                 ru_rhs = rhs })
 444   = hang (doubleQuotes (ftext name) <+> ppr act)
 445        4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 446                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
 447                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
 448             ])
 449 \end{code}