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