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