58a940c72a4779990f393924b0f6c0c5d157d10f
[ghc.git] / 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      = pprTypedLetBinder binder $$ 
275                      ppIdInfo binder (idInfo binder)
276
277 -- Lambda bound type variables are preceded by "@"
278 pprCoreBinder bind_site bndr 
279   = getPprStyle $ \ sty ->
280     pprTypedLamBinder 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 pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
288 -- For lambda and case binders, show the unfolding info (usually none)
289 pprTypedLamBinder 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   | opt_SuppressAll                     = pprUntypedBinder var  -- Suppress the signature
293   | isTyVar var                         = parens (pprKindedTyVarBndr var)
294   | otherwise = parens (hang (pprIdBndr var) 
295                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
296   where
297     unf_info = unfoldingInfo (idInfo var)
298     pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
299            | otherwise                 = empty
300
301 pprTypedLetBinder :: Var -> SDoc
302 -- Print binder with a type or kind signature (not paren'd)
303 pprTypedLetBinder binder
304   | isTyVar binder             = pprKindedTyVarBndr binder
305   | opt_SuppressTypeSignatures = pprIdBndr binder
306   | otherwise                  = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
307
308 pprKindedTyVarBndr :: TyVar -> SDoc
309 -- Print a type variable binder with its kind (but not if *)
310 pprKindedTyVarBndr tyvar
311   = ptext (sLit "@") <+> ppr tyvar <> opt_kind
312   where
313     opt_kind    -- Print the kind if not *
314         | isLiftedTypeKind kind = empty
315         | otherwise = dcolon <> pprKind kind
316     kind = tyVarKind tyvar
317
318 -- pprIdBndr does *not* print the type
319 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
320 pprIdBndr :: Id -> SDoc
321 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
322
323 pprIdBndrInfo :: IdInfo -> SDoc
324 pprIdBndrInfo info 
325   | opt_SuppressIdInfo = empty
326   | otherwise
327   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
328   where
329     prag_info = inlinePragInfo info
330     occ_info  = occInfo info
331     dmd_info  = demandInfo info
332     lbv_info  = lbvarInfo info
333
334     has_prag = not (isDefaultInlinePragma prag_info)
335     has_occ  = not (isNoOcc occ_info)
336     has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
337     has_lbv  = not (hasNoLBVarInfo lbv_info)
338
339     doc = showAttributes 
340           [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
341           , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
342           , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
343           , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
344           ]
345 \end{code}
346
347
348 -----------------------------------------------------
349 --      IdDetails and IdInfo
350 -----------------------------------------------------
351
352 \begin{code}
353 ppIdInfo :: Id -> IdInfo -> SDoc
354 ppIdInfo id info
355   | opt_SuppressIdInfo  = empty
356   | otherwise
357   = showAttributes
358     [ (True, pp_scope <> ppr (idDetails id))
359     , (has_arity,      ptext (sLit "Arity=") <> int arity)
360     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
361     , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
362     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
363     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
364     ]   -- Inline pragma, occ, demand, lbvar info
365         -- printed out with all binders (when debug is on); 
366         -- see PprCore.pprIdBndr
367   where
368     pp_scope | isGlobalId id   = ptext (sLit "GblId")
369              | isExportedId id = ptext (sLit "LclIdX")
370              | otherwise       = ptext (sLit "LclId")
371
372     arity = arityInfo info
373     has_arity = arity /= 0
374
375     caf_info = cafInfo info
376     has_caf_info = not (mayHaveCafRefs caf_info)
377
378     str_info = strictnessInfo info
379     has_strictness = isJust str_info
380
381     unf_info = unfoldingInfo info
382     has_unf = hasSomeUnfolding unf_info
383
384     rules = specInfoRules (specInfo info)
385
386 showAttributes :: [(Bool,SDoc)] -> SDoc
387 showAttributes stuff 
388   | null docs = empty
389   | otherwise = brackets (sep (punctuate comma docs))
390   where
391     docs = [d | (True,d) <- stuff]
392 \end{code}
393
394 -----------------------------------------------------
395 --      Unfolding and UnfoldingGuidance
396 -----------------------------------------------------
397
398 \begin{code}
399 instance Outputable UnfoldingGuidance where
400     ppr UnfNever  = ptext (sLit "NEVER")
401     ppr (UnfWhen unsat_ok boring_ok)
402       = ptext (sLit "ALWAYS_IF") <> 
403         parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
404                 ptext (sLit "boring_ok=") <> ppr boring_ok)
405     ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
406       = hsep [ ptext (sLit "IF_ARGS"), 
407                brackets (hsep (map int cs)),
408                int size,
409                int discount ]
410
411 instance Outputable UnfoldingSource where
412   ppr InlineCompulsory  = ptext (sLit "Compulsory")
413   ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
414   ppr InlineStable      = ptext (sLit "InlineStable")
415   ppr InlineRhs         = ptext (sLit "<vanilla>")
416
417 instance Outputable Unfolding where
418   ppr NoUnfolding                = ptext (sLit "No unfolding")
419   ppr (OtherCon cs)              = ptext (sLit "OtherCon") <+> ppr cs
420   ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)  
421                                    <+> ppr con <+> brackets (pprWithCommas ppr ops)
422   ppr (CoreUnfolding { uf_src = src
423                      , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
424                      , uf_is_conlike=conlike, uf_is_cheap=cheap
425                      , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) 
426         = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
427     where
428       pp_info = fsep $ punctuate comma 
429                 [ ptext (sLit "Src=")        <> ppr src
430                 , ptext (sLit "TopLvl=")     <> ppr top 
431                 , ptext (sLit "Arity=")      <> int arity
432                 , ptext (sLit "Value=")      <> ppr hnf
433                 , ptext (sLit "ConLike=")    <> ppr conlike
434                 , ptext (sLit "Cheap=")      <> ppr cheap
435                 , ptext (sLit "Expandable=") <> ppr exp
436                 , ptext (sLit "Guidance=")   <> ppr g ]
437       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
438       pp_rhs | isStableSource src = pp_tmpl
439              | otherwise          = empty
440             -- Don't print the RHS or we get a quadratic 
441             -- blowup in the size of the printout!
442 \end{code}
443
444 -----------------------------------------------------
445 --      Rules
446 -----------------------------------------------------
447
448 \begin{code}
449 instance Outputable CoreRule where
450    ppr = pprRule
451
452 pprRules :: [CoreRule] -> SDoc
453 pprRules rules = vcat (map pprRule rules)
454
455 pprRule :: CoreRule -> SDoc
456 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
457   = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
458
459 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
460                 ru_bndrs = tpl_vars, ru_args = tpl_args,
461                 ru_rhs = rhs })
462   = hang (doubleQuotes (ftext name) <+> ppr act)
463        4 (sep [ptext (sLit "forall") <+> 
464                   sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
465                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
466                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
467             ])
468 \end{code}
469
470 -----------------------------------------------------
471 --      Vectorisation declarations
472 -----------------------------------------------------
473
474 \begin{code}
475 instance Outputable CoreVect where
476   ppr (Vect   var Nothing)  = ptext (sLit "VECTORISE SCALAR") <+> ppr var
477   ppr (Vect   var (Just e)) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
478                                 4 (pprCoreExpr e)
479   ppr (NoVect var)          = ptext (sLit "NOVECTORISE") <+> ppr var
480 \end{code}