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 add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
 112
 113 ppr_expr _       (Var name) = ppr name
 114 ppr_expr _       (Lit lit)  = ppr lit
 115
 116 ppr_expr add_par (Cast expr co)
 117   = add_par $
 118     sep [pprParendExpr expr,
 119          ptext (sLit "`cast`") <+> pprCo co]
 120   where
 121     pprCo co | opt_SuppressCoercions = ptext (sLit "...")
 122              | otherwise = parens
 123                          $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
 124
 125
 126 ppr_expr add_par expr@(Lam _ _)
 127   = let
 128         (bndrs, body) = collectBinders expr
 129     in
 130     add_par $
 131     hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
 132          2 (pprCoreExpr body)
 133
 134 ppr_expr add_par expr@(App {})
 135   = case collectArgs expr of { (fun, args) ->
 136     let
 137         pp_args     = sep (map pprArg args)
 138         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
 139         pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
 140     in
 141     case fun of
 142         Var f -> case isDataConWorkId_maybe f of
 143                         -- Notice that we print the *worker*
 144                         -- for tuples in paren'd format.
 145                    Just dc | saturated && isTupleTyCon tc
 146                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
 147                            where
 148                              tc        = dataConTyCon dc
 149                              saturated = val_args `lengthIs` idArity f
 150
 151                    _ -> add_par (hang (ppr f) 2 pp_args)
 152
 153         _ -> add_par (hang (pprParendExpr fun) 2 pp_args)
 154     }
 155
 156 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
 157   | opt_PprCaseAsLet
 158   = add_par $
 159     sep [sep    [ ptext (sLit "let")
 160                         <+> char '{'
 161                         <+> ppr_case_pat con args
 162                         <+> ptext (sLit "~")
 163                         <+> ppr_bndr var
 164                 , ptext (sLit "<-")
 165                         <+> ppr_expr id expr
 166                 , char '}'
 167                         <+> ptext (sLit "in")
 168                 ]
 169         , pprCoreExpr rhs
 170         ]
 171
 172   | otherwise
 173   = add_par $
 174     sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
 175               ifPprDebug (braces (ppr ty)),
 176               sep [ptext (sLit "of") <+> ppr_bndr var,
 177                    char '{' <+> ppr_case_pat con args <+> arrow]
 178           ],
 179          pprCoreExpr rhs,
 180          char '}'
 181     ]
 182   where
 183     ppr_bndr = pprBndr CaseBind
 184
 185 ppr_expr add_par (Case expr var ty alts)
 186   = add_par $
 187     sep [sep [ptext (sLit "case")
 188                 <+> pprCoreExpr expr
 189                 <+> ifPprDebug (braces (ppr ty)),
 190               ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
 191          nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
 192          char '}'
 193     ]
 194   where
 195     ppr_bndr = pprBndr CaseBind
 196
 197
 198 -- special cases: let ... in let ...
 199 -- ("disgusting" SLPJ)
 200
 201 {-
 202 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 203   = add_par $
 204     vcat [
 205       hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
 206       nest 2 (pprCoreExpr rhs),
 207       ptext (sLit "} in"),
 208       pprCoreExpr body ]
 209
 210 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 211   = add_par
 212     (hang (ptext (sLit "let {"))
 213           2 (hsep [ppr_binding (val_bdr,rhs),
 214                    ptext (sLit "} in")])
 215      $$
 216      pprCoreExpr expr)
 217 -}
 218
 219 -- General case (recursive case, too)
 220 ppr_expr add_par (Let bind expr)
 221   = add_par $
 222     sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")),
 223          pprCoreExpr expr]
 224   where
 225     keyword = case bind of
 226                 Rec _      -> (sLit "letrec {")
 227                 NonRec _ _ -> (sLit "let {")
 228
 229 ppr_expr add_par (Note (SCC cc) expr)
 230   = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
 231
 232 ppr_expr add_par (Note (CoreNote s) expr)
 233   = add_par $
 234     sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
 235          pprParendExpr expr]
 236
 237 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
 238 pprCoreAlt (con, args, rhs)
 239   = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)
 240
 241 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
 242 ppr_case_pat (DataAlt dc) args
 243   | isTupleTyCon tc
 244   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args)))
 245   where
 246     ppr_bndr = pprBndr CaseBind
 247     tc = dataConTyCon dc
 248
 249 ppr_case_pat con args
 250   = ppr con <+> sep (map ppr_bndr args)
 251   where
 252     ppr_bndr = pprBndr CaseBind
 253
 254
 255 -- | Pretty print the argument in a function application.
 256 pprArg :: OutputableBndr a => Expr a -> SDoc
 257 pprArg (Type ty)
 258  | opt_SuppressTypeApplications = empty
 259  | otherwise                    = ptext (sLit "@") <+> pprParendType ty
 260 pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
 261 pprArg expr          = pprParendExpr expr
 262 \end{code}
 263
 264 Other printing bits-and-bobs used with the general @pprCoreBinding@
 265 and @pprCoreExpr@ functions.
 266
 267 \begin{code}
 268 instance OutputableBndr Var where
 269   pprBndr = pprCoreBinder
 270
 271 pprCoreBinder :: BindingSite -> Var -> SDoc
 272 pprCoreBinder LetBind binder
 273   | isTyVar binder = pprKindedTyVarBndr binder
 274   | otherwise      = pprTypedBinder binder $$
 275                      ppIdInfo binder (idInfo binder)
 276
 277 -- Lambda bound type variables are preceded by "@"
 278 pprCoreBinder bind_site bndr
 279   = getPprStyle $ \ sty ->
 280     pprTypedLCBinder bind_site (debugStyle sty) 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 pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
 288 -- For lambda and case binders, show the unfolding info (usually none)
 289 pprTypedLCBinder bind_site debug_on var
 290   | not debug_on && isDeadBinder var    = char '_'
 291   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
 292   | isTyVar var                         = parens (pprKindedTyVarBndr var)
 293   | otherwise = parens (hang (pprIdBndr var)
 294                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
 295               where
 296                 unf_info = unfoldingInfo (idInfo var)
 297                 pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
 298                        | otherwise                 = empty
 299
 300 pprTypedBinder :: Var -> SDoc
 301 -- Print binder with a type or kind signature (not paren'd)
 302 pprTypedBinder binder
 303   | isTyVar binder              = pprKindedTyVarBndr binder
 304   | opt_SuppressTypeSignatures  = empty
 305   | otherwise                   = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 306
 307 pprKindedTyVarBndr :: TyVar -> SDoc
 308 -- Print a type variable binder with its kind (but not if *)
 309 pprKindedTyVarBndr tyvar
 310   = ptext (sLit "@") <+> ppr tyvar <> opt_kind
 311   where
 312     opt_kind    -- Print the kind if not *
 313         | isLiftedTypeKind kind = empty
 314         | otherwise = dcolon <> pprKind kind
 315     kind = tyVarKind tyvar
 316
 317 -- pprIdBndr does *not* print the type
 318 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 319 pprIdBndr :: Id -> SDoc
 320 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 321
 322 pprIdBndrInfo :: IdInfo -> SDoc
 323 pprIdBndrInfo info
 324   | opt_SuppressIdInfo = empty
 325   | otherwise
 326   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
 327   where
 328     prag_info = inlinePragInfo info
 329     occ_info  = occInfo info
 330     dmd_info  = demandInfo info
 331     lbv_info  = lbvarInfo info
 332
 333     has_prag = not (isDefaultInlinePragma prag_info)
 334     has_occ  = not (isNoOcc occ_info)
 335     has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
 336     has_lbv  = not (hasNoLBVarInfo lbv_info)
 337
 338     doc = showAttributes
 339           [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
 340           , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
 341           , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
 342           , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
 343           ]
 344 \end{code}
 345
 346
 347 -----------------------------------------------------
 348 --      IdDetails and IdInfo
 349 -----------------------------------------------------
 350
 351 \begin{code}
 352 ppIdInfo :: Id -> IdInfo -> SDoc
 353 ppIdInfo id info
 354   | opt_SuppressIdInfo  = empty
 355   | otherwise
 356   = showAttributes
 357     [ (True, pp_scope <> ppr (idDetails id))
 358     , (has_arity,      ptext (sLit "Arity=") <> int arity)
 359     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
 360     , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
 361     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
 362     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
 363     ]   -- Inline pragma, occ, demand, lbvar info
 364         -- printed out with all binders (when debug is on);
 365         -- see PprCore.pprIdBndr
 366   where
 367     pp_scope | isGlobalId id   = ptext (sLit "GblId")
 368              | isExportedId id = ptext (sLit "LclIdX")
 369              | otherwise       = ptext (sLit "LclId")
 370
 371     arity = arityInfo info
 372     has_arity = arity /= 0
 373
 374     caf_info = cafInfo info
 375     has_caf_info = not (mayHaveCafRefs caf_info)
 376
 377     str_info = strictnessInfo info
 378     has_strictness = isJust str_info
 379
 380     unf_info = unfoldingInfo info
 381     has_unf = hasSomeUnfolding unf_info
 382
 383     rules = specInfoRules (specInfo info)
 384
 385 showAttributes :: [(Bool,SDoc)] -> SDoc
 386 showAttributes stuff
 387   | null docs = empty
 388   | otherwise = brackets (sep (punctuate comma docs))
 389   where
 390     docs = [d | (True,d) <- stuff]
 391 \end{code}
 392
 393 -----------------------------------------------------
 394 --      Unfolding and UnfoldingGuidance
 395 -----------------------------------------------------
 396
 397 \begin{code}
 398 instance Outputable UnfoldingGuidance where
 399     ppr UnfNever  = ptext (sLit "NEVER")
 400     ppr (UnfWhen unsat_ok boring_ok)
 401       = ptext (sLit "ALWAYS_IF") <>
 402         parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
 403                 ptext (sLit "boring_ok=") <> ppr boring_ok)
 404     ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
 405       = hsep [ ptext (sLit "IF_ARGS"),
 406                brackets (hsep (map int cs)),
 407                int size,
 408                int discount ]
 409
 410 instance Outputable UnfoldingSource where
 411   ppr InlineCompulsory  = ptext (sLit "Compulsory")
 412   ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
 413   ppr InlineStable      = ptext (sLit "InlineStable")
 414   ppr InlineRhs         = ptext (sLit "<vanilla>")
 415
 416 instance Outputable Unfolding where
 417   ppr NoUnfolding                = ptext (sLit "No unfolding")
 418   ppr (OtherCon cs)              = ptext (sLit "OtherCon") <+> ppr cs
 419   ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
 420                                    <+> ppr con <+> brackets (pprWithCommas ppr ops)
 421   ppr (CoreUnfolding { uf_src = src
 422                      , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
 423                      , uf_is_conlike=conlike, uf_is_cheap=cheap
 424                      , uf_expandable=exp, uf_guidance=g, uf_arity=arity})
 425         = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
 426     where
 427       pp_info = fsep $ punctuate comma
 428                 [ ptext (sLit "Src=")        <> ppr src
 429                 , ptext (sLit "TopLvl=")     <> ppr top
 430                 , ptext (sLit "Arity=")      <> int arity
 431                 , ptext (sLit "Value=")      <> ppr hnf
 432                 , ptext (sLit "ConLike=")    <> ppr conlike
 433                 , ptext (sLit "Cheap=")      <> ppr cheap
 434                 , ptext (sLit "Expandable=") <> ppr exp
 435                 , ptext (sLit "Guidance=")   <> ppr g ]
 436       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
 437       pp_rhs | isStableSource src = pp_tmpl
 438              | otherwise          = empty
 439             -- Don't print the RHS or we get a quadratic
 440             -- blowup in the size of the printout!
 441
 442 instance Outputable e => Outputable (DFunArg e) where
 443   ppr (DFunPolyArg e)  = braces (ppr e)
 444   ppr (DFunConstArg e) = ppr e
 445   ppr (DFunLamArg i)   = char '<' <> int i <> char '>'
 446 \end{code}
 447
 448 -----------------------------------------------------
 449 --      Rules
 450 -----------------------------------------------------
 451
 452 \begin{code}
 453 instance Outputable CoreRule where
 454    ppr = pprRule
 455
 456 pprRules :: [CoreRule] -> SDoc
 457 pprRules rules = vcat (map pprRule rules)
 458
 459 pprRule :: CoreRule -> SDoc
 460 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
 461   = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
 462
 463 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
 464                 ru_bndrs = tpl_vars, ru_args = tpl_args,
 465                 ru_rhs = rhs })
 466   = hang (doubleQuotes (ftext name) <+> ppr act)
 467        4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 468                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
 469                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
 470             ])
 471 \end{code}