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 \end{code}
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection{Public interfaces for Core printing (excluding instances)}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  44
  45 \begin{code}
  46 pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
  47 pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc
  48 pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc
  49 pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc
  50
  51 pprCoreBindings = pprTopBinds
  52 pprCoreBinding  = pprTopBind
  53
  54 instance OutputableBndr b => Outputable (Bind b) where
  55     ppr bind = ppr_bind bind
  56
  57 instance OutputableBndr b => Outputable (Expr b) where
  58     ppr expr = pprCoreExpr expr
  59 \end{code}
  60
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \subsection{The guts}
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 \begin{code}
  69 pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc
  70 pprTopBinds binds = vcat (map pprTopBind binds)
  71
  72 pprTopBind :: OutputableBndr a => Bind a -> SDoc
  73 pprTopBind (NonRec binder expr)
  74  = ppr_binding (binder,expr) $$ blankLine
  75
  76 pprTopBind (Rec [])
  77   = ptext (sLit "Rec { }")
  78 pprTopBind (Rec (b:bs))
  79   = vcat [ptext (sLit "Rec {"),
  80           ppr_binding b,
  81           vcat [blankLine $$ ppr_binding b | b <- bs],
  82           ptext (sLit "end Rec }"),
  83           blankLine]
  84 \end{code}
  85
  86 \begin{code}
  87 ppr_bind :: OutputableBndr b => Bind b -> SDoc
  88
  89 ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
  90 ppr_bind (Rec binds)           = vcat (map pp binds)
  91                                where
  92                                  pp bind = ppr_binding bind <> semi
  93
  94 ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
  95 ppr_binding (val_bdr, expr)
  96   = pprBndr LetBind val_bdr $$
  97     hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
  98 \end{code}
  99
 100 \begin{code}
 101 pprParendExpr   expr = ppr_expr parens expr
 102 pprCoreExpr expr = ppr_expr noParens expr
 103
 104 noParens :: SDoc -> SDoc
 105 noParens pp = pp
 106 \end{code}
 107
 108 \begin{code}
 109 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
 110         -- The function adds parens in context that need
 111         -- an atomic value (e.g. function args)
 112
 113 ppr_expr add_par (Type ty)  = add_par (ptext (sLit "TYPE") <+> ppr ty)  -- Wierd
 114
 115 ppr_expr _       (Var name) = ppr name
 116 ppr_expr _       (Lit lit)  = ppr lit
 117
 118 ppr_expr add_par (Cast expr co)
 119   = add_par $
 120     sep [pprParendExpr expr,
 121          ptext (sLit "`cast`") <+> pprCo co]
 122   where
 123     pprCo co | opt_SuppressCoercions = ptext (sLit "...")
 124              | otherwise = parens
 125                          $ sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)]
 126
 127
 128 ppr_expr add_par expr@(Lam _ _)
 129   = let
 130         (bndrs, body) = collectBinders expr
 131     in
 132     add_par $
 133     hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
 134          2 (pprCoreExpr body)
 135
 136 ppr_expr add_par expr@(App {})
 137   = case collectArgs expr of { (fun, args) ->
 138     let
 139         pp_args     = sep (map pprArg args)
 140         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
 141         pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
 142     in
 143     case fun of
 144         Var f -> case isDataConWorkId_maybe f of
 145                         -- Notice that we print the *worker*
 146                         -- for tuples in paren'd format.
 147                    Just dc | saturated && isTupleTyCon tc
 148                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
 149                            where
 150                              tc        = dataConTyCon dc
 151                              saturated = val_args `lengthIs` idArity f
 152
 153                    _ -> add_par (hang (ppr f) 2 pp_args)
 154
 155         _ -> add_par (hang (pprParendExpr fun) 2 pp_args)
 156     }
 157
 158 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
 159   = add_par $
 160     sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
 161               ifPprDebug (braces (ppr ty)),
 162               sep [ptext (sLit "of") <+> ppr_bndr var,
 163                    char '{' <+> ppr_case_pat con args]
 164           ],
 165          pprCoreExpr rhs,
 166          char '}'
 167     ]
 168   where
 169     ppr_bndr = pprBndr CaseBind
 170
 171 ppr_expr add_par (Case expr var ty alts)
 172   = add_par $
 173     sep [sep [ptext (sLit "case")
 174                 <+> pprCoreExpr expr
 175                 <+> ifPprDebug (braces (ppr ty)),
 176               ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
 177          nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
 178          char '}'
 179     ]
 180   where
 181     ppr_bndr = pprBndr CaseBind
 182
 183
 184 -- special cases: let ... in let ...
 185 -- ("disgusting" SLPJ)
 186
 187 {-
 188 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 189   = add_par $
 190     vcat [
 191       hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
 192       nest 2 (pprCoreExpr rhs),
 193       ptext (sLit "} in"),
 194       pprCoreExpr body ]
 195
 196 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 197   = add_par
 198     (hang (ptext (sLit "let {"))
 199           2 (hsep [ppr_binding (val_bdr,rhs),
 200                    ptext (sLit "} in")])
 201      $$
 202      pprCoreExpr expr)
 203 -}
 204
 205 -- General case (recursive case, too)
 206 ppr_expr add_par (Let bind expr)
 207   = add_par $
 208     sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")),
 209          pprCoreExpr expr]
 210   where
 211     keyword = case bind of
 212                 Rec _      -> (sLit "letrec {")
 213                 NonRec _ _ -> (sLit "let {")
 214
 215 ppr_expr add_par (Note (SCC cc) expr)
 216   = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
 217
 218 ppr_expr add_par (Note InlineMe expr)
 219   = add_par $ ptext (sLit "__inline_me") <+> pprParendExpr expr
 220
 221 ppr_expr add_par (Note (CoreNote s) expr)
 222   = add_par $
 223     sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
 224          pprParendExpr expr]
 225
 226 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
 227 pprCoreAlt (con, args, rhs)
 228   = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
 229
 230 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
 231 ppr_case_pat (DataAlt dc) args
 232   | isTupleTyCon tc
 233   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
 234   where
 235     ppr_bndr = pprBndr CaseBind
 236     tc = dataConTyCon dc
 237
 238 ppr_case_pat con args
 239   = ppr con <+> sep (map ppr_bndr args) <+> arrow
 240   where
 241     ppr_bndr = pprBndr CaseBind
 242
 243 pprArg :: OutputableBndr a => Expr a -> SDoc
 244 pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty
 245 pprArg expr      = pprParendExpr expr
 246 \end{code}
 247
 248 Other printing bits-and-bobs used with the general @pprCoreBinding@
 249 and @pprCoreExpr@ functions.
 250
 251 \begin{code}
 252 instance OutputableBndr Var where
 253   pprBndr = pprCoreBinder
 254
 255 pprCoreBinder :: BindingSite -> Var -> SDoc
 256 pprCoreBinder LetBind binder
 257   | isTyVar binder = pprKindedTyVarBndr binder
 258   | otherwise
 259   = vcat [sig, pprIdExtras binder, pragmas]
 260   where
 261     sig     = pprTypedBinder binder
 262     pragmas = ppIdInfo binder (idInfo binder)
 263
 264 -- Lambda bound type variables are preceded by "@"
 265 pprCoreBinder LambdaBind bndr
 266   | isDeadBinder bndr
 267   = getPprStyle $ \ sty ->
 268     if debugStyle sty then
 269         parens (pprTypedBinder bndr)
 270     else
 271         char '_'
 272   | otherwise
 273   = parens (pprTypedBinder bndr)
 274
 275 -- Case bound things don't get a signature or a herald, unless we have debug on
 276 pprCoreBinder CaseBind bndr
 277   = getPprStyle $ \ sty ->
 278     if debugStyle sty then
 279         parens (pprTypedBinder bndr)
 280     else
 281         if isDeadBinder bndr then char '_'
 282         else pprUntypedBinder bndr
 283
 284 pprUntypedBinder :: Var -> SDoc
 285 pprUntypedBinder binder
 286   | isTyVar binder = ptext (sLit "@") <+> ppr binder    -- NB: don't print kind
 287   | otherwise      = pprIdBndr binder
 288
 289 pprTypedBinder :: Var -> SDoc
 290 -- Print binder with a type or kind signature (not paren'd)
 291 pprTypedBinder binder
 292   | isTyVar binder  = pprKindedTyVarBndr binder
 293   | otherwise       = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
 294
 295 pprKindedTyVarBndr :: TyVar -> SDoc
 296 -- Print a type variable binder with its kind (but not if *)
 297 pprKindedTyVarBndr tyvar
 298   = ptext (sLit "@") <+> ppr tyvar <> opt_kind
 299   where
 300     opt_kind    -- Print the kind if not *
 301         | isLiftedTypeKind kind = empty
 302         | otherwise = dcolon <> pprKind kind
 303     kind = tyVarKind tyvar
 304
 305 -- pprIdBndr does *not* print the type
 306 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 307 pprIdBndr :: Id -> SDoc
 308 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 309
 310 pprIdBndrInfo :: IdInfo -> SDoc
 311 pprIdBndrInfo info
 312   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
 313   where
 314     prag_info = inlinePragInfo info
 315     occ_info  = occInfo info
 316     dmd_info  = newDemandInfo info
 317     lbv_info  = lbvarInfo info
 318
 319     no_info = isDefaultInlinePragma prag_info && isNoOcc occ_info &&
 320               (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
 321               hasNoLBVarInfo lbv_info
 322
 323     doc | no_info = empty
 324         | otherwise
 325         = brackets $ hsep [ppr prag_info, ppr occ_info,
 326                            ppr dmd_info, ppr lbv_info
 327 #ifdef OLD_STRICTNESS
 328                            , ppr (demandInfo id)
 329 #endif
 330                           ]
 331 \end{code}
 332
 333
 334 \begin{code}
 335 pprIdExtras :: Id -> SDoc
 336 pprIdExtras id = pp_scope <> ppr (idDetails id)
 337   where
 338     pp_scope | isGlobalId id   = ptext (sLit "GblId")
 339              | isExportedId id = ptext (sLit "LclIdX")
 340              | otherwise       = ptext (sLit "LclId")
 341
 342 ppIdInfo :: Id -> IdInfo -> SDoc
 343 ppIdInfo _ info
 344   = brackets $
 345     vcat [  ppArityInfo a,
 346             ppWorkerInfo (workerInfo info),
 347             ppCafInfo (cafInfo info),
 348 #ifdef OLD_STRICTNESS
 349             ppStrictnessInfo s,
 350             ppCprInfo m,
 351 #endif
 352             pprNewStrictness (newStrictnessInfo info),
 353             if null rules then empty
 354             else ptext (sLit "RULES:") <+> vcat (map pprRule rules)
 355         -- Inline pragma, occ, demand, lbvar info
 356         -- printed out with all binders (when debug is on);
 357         -- see PprCore.pprIdBndr
 358         ]
 359   where
 360     a = arityInfo info
 361 #ifdef OLD_STRICTNESS
 362     s = strictnessInfo info
 363     m = cprInfo info
 364 #endif
 365     rules = specInfoRules (specInfo info)
 366 \end{code}
 367
 368
 369 \begin{code}
 370 instance Outputable CoreRule where
 371    ppr = pprRule
 372
 373 pprRules :: [CoreRule] -> SDoc
 374 pprRules rules = vcat (map pprRule rules)
 375
 376 pprRule :: CoreRule -> SDoc
 377 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
 378   = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
 379
 380 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
 381                 ru_bndrs = tpl_vars, ru_args = tpl_args,
 382                 ru_rhs = rhs })
 383   = hang (doubleQuotes (ftext name) <+> ppr act)
 384        4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 385                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
 386                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
 387             ])
 388 \end{code}