Add kind equalities to GHC.
[ghc.git] / compiler / coreSyn / PprCore.hs
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
9 {-# OPTIONS_GHC -fno-warn-orphans #-}
10 module PprCore (
11 pprCoreExpr, pprParendExpr,
12 pprCoreBinding, pprCoreBindings, pprCoreAlt,
13 pprCoreBindingWithSize, pprCoreBindingsWithSize,
14 pprRules
15 ) where
16
17 import CoreSyn
18 import CoreStats (exprStats)
19 import Literal( pprLiteral )
20 import Name( pprInfixName, pprPrefixName )
21 import Var
22 import Id
23 import IdInfo
24 import Demand
25 import DataCon
26 import TyCon
27 import Type
28 import Coercion
29 import DynFlags
30 import BasicTypes
31 import Util
32 import Outputable
33 import FastString
34 import SrcLoc ( pprUserRealSpan )
35
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
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 noAnn
52 pprCoreBinding = pprTopBind noAnn
53
54 pprCoreBindingsWithSize :: [CoreBind] -> SDoc
55 pprCoreBindingWithSize :: CoreBind -> SDoc
56
57 pprCoreBindingsWithSize = pprTopBinds sizeAnn
58 pprCoreBindingWithSize = pprTopBind sizeAnn
59
60 instance OutputableBndr b => Outputable (Bind b) where
61 ppr bind = ppr_bind noAnn bind
62
63 instance OutputableBndr b => Outputable (Expr b) where
64 ppr expr = pprCoreExpr expr
65
66 {-
67 ************************************************************************
68 * *
69 \subsection{The guts}
70 * *
71 ************************************************************************
72 -}
73
74 -- | A function to produce an annotation for a given right-hand-side
75 type Annotation b = Expr b -> SDoc
76
77 -- | Annotate with the size of the right-hand-side
78 sizeAnn :: CoreExpr -> SDoc
79 sizeAnn e = ptext (sLit "-- RHS size:") <+> ppr (exprStats e)
80
81 -- | No annotation
82 noAnn :: Expr b -> SDoc
83 noAnn _ = empty
84
85 pprTopBinds :: OutputableBndr a
86 => Annotation a -- ^ generate an annotation to place before the
87 -- binding
88 -> [Bind a] -- ^ bindings to show
89 -> SDoc -- ^ the pretty result
90 pprTopBinds ann binds = vcat (map (pprTopBind ann) binds)
91
92 pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc
93 pprTopBind ann (NonRec binder expr)
94 = ppr_binding ann (binder,expr) $$ blankLine
95
96 pprTopBind _ (Rec [])
97 = ptext (sLit "Rec { }")
98 pprTopBind ann (Rec (b:bs))
99 = vcat [ptext (sLit "Rec {"),
100 ppr_binding ann b,
101 vcat [blankLine $$ ppr_binding ann b | b <- bs],
102 ptext (sLit "end Rec }"),
103 blankLine]
104
105 ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc
106
107 ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr)
108 ppr_bind ann (Rec binds) = vcat (map pp binds)
109 where
110 pp bind = ppr_binding ann bind <> semi
111
112 ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
113 ppr_binding ann (val_bdr, expr)
114 = ann expr $$ pprBndr LetBind val_bdr $$
115 hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
116
117 pprParendExpr expr = ppr_expr parens expr
118 pprCoreExpr expr = ppr_expr noParens expr
119
120 noParens :: SDoc -> SDoc
121 noParens pp = pp
122
123 pprOptCo :: Coercion -> SDoc
124 pprOptCo co = sdocWithDynFlags $ \dflags ->
125 if gopt Opt_SuppressCoercions dflags
126 then ptext (sLit "...")
127 else parens (sep [ppr co, dcolon <+> ppr (coercionType co)])
128
129 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
130 -- The function adds parens in context that need
131 -- an atomic value (e.g. function args)
132
133 ppr_expr _ (Var name) = ppr name
134 ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE:") <+> ppr ty) -- Weird
135 ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO:") <+> ppr co)
136 ppr_expr add_par (Lit lit) = pprLiteral add_par lit
137
138 ppr_expr add_par (Cast expr co)
139 = add_par $ sep [pprParendExpr expr, ptext (sLit "`cast`") <+> pprOptCo co]
140
141 ppr_expr add_par expr@(Lam _ _)
142 = let
143 (bndrs, body) = collectBinders expr
144 in
145 add_par $
146 hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
147 2 (pprCoreExpr body)
148
149 ppr_expr add_par expr@(App {})
150 = case collectArgs expr of { (fun, args) ->
151 let
152 pp_args = sep (map pprArg args)
153 val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
154 pp_tup_args = pprWithCommas pprCoreExpr val_args
155 in
156 case fun of
157 Var f -> case isDataConWorkId_maybe f of
158 -- Notice that we print the *worker*
159 -- for tuples in paren'd format.
160 Just dc | saturated
161 , Just sort <- tyConTuple_maybe tc
162 -> tupleParens sort pp_tup_args
163 where
164 tc = dataConTyCon dc
165 saturated = val_args `lengthIs` idArity f
166
167 _ -> add_par (hang (ppr f) 2 pp_args)
168
169 _ -> add_par (hang (pprParendExpr fun) 2 pp_args)
170 }
171
172 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
173 = sdocWithDynFlags $ \dflags ->
174 if gopt Opt_PprCaseAsLet dflags
175 then add_par $ -- See Note [Print case as let]
176 sep [ sep [ ptext (sLit "let! {")
177 <+> ppr_case_pat con args
178 <+> ptext (sLit "~")
179 <+> ppr_bndr var
180 , ptext (sLit "<-") <+> ppr_expr id expr
181 <+> ptext (sLit "} in") ]
182 , pprCoreExpr rhs
183 ]
184 else add_par $
185 sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
186 ifPprDebug (text "return" <+> ppr ty),
187 sep [ptext (sLit "of") <+> ppr_bndr var,
188 char '{' <+> ppr_case_pat con args <+> arrow]
189 ],
190 pprCoreExpr rhs,
191 char '}'
192 ]
193 where
194 ppr_bndr = pprBndr CaseBind
195
196 ppr_expr add_par (Case expr var ty alts)
197 = add_par $
198 sep [sep [ptext (sLit "case")
199 <+> pprCoreExpr expr
200 <+> ifPprDebug (text "return" <+> ppr ty),
201 ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
202 nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
203 char '}'
204 ]
205 where
206 ppr_bndr = pprBndr CaseBind
207
208
209 -- special cases: let ... in let ...
210 -- ("disgusting" SLPJ)
211
212 {-
213 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
214 = add_par $
215 vcat [
216 hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
217 nest 2 (pprCoreExpr rhs),
218 ptext (sLit "} in"),
219 pprCoreExpr body ]
220
221 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
222 = add_par
223 (hang (ptext (sLit "let {"))
224 2 (hsep [ppr_binding (val_bdr,rhs),
225 ptext (sLit "} in")])
226 $$
227 pprCoreExpr expr)
228 -}
229
230 -- General case (recursive case, too)
231 ppr_expr add_par (Let bind expr)
232 = add_par $
233 sep [hang (ptext keyword) 2 (ppr_bind noAnn bind <+> ptext (sLit "} in")),
234 pprCoreExpr expr]
235 where
236 keyword = case bind of
237 Rec _ -> (sLit "letrec {")
238 NonRec _ _ -> (sLit "let {")
239
240 ppr_expr add_par (Tick tickish expr)
241 = sdocWithDynFlags $ \dflags ->
242 if gopt Opt_PprShowTicks dflags
243 then add_par (sep [ppr tickish, pprCoreExpr expr])
244 else ppr_expr add_par expr
245
246 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
247 pprCoreAlt (con, args, rhs)
248 = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)
249
250 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
251 ppr_case_pat (DataAlt dc) args
252 | Just sort <- tyConTuple_maybe tc
253 = tupleParens sort (pprWithCommas ppr_bndr args)
254 where
255 ppr_bndr = pprBndr CaseBind
256 tc = dataConTyCon dc
257
258 ppr_case_pat con args
259 = ppr con <+> (fsep (map ppr_bndr args))
260 where
261 ppr_bndr = pprBndr CaseBind
262
263
264 -- | Pretty print the argument in a function application.
265 pprArg :: OutputableBndr a => Expr a -> SDoc
266 pprArg (Type ty)
267 = sdocWithDynFlags $ \dflags ->
268 if gopt Opt_SuppressTypeApplications dflags
269 then empty
270 else ptext (sLit "@") <+> pprParendType ty
271 pprArg (Coercion co) = ptext (sLit "@~") <+> pprOptCo co
272 pprArg expr = pprParendExpr expr
273
274 {-
275 Note [Print case as let]
276 ~~~~~~~~~~~~~~~~~~~~~~~~
277 Single-branch case expressions are very common:
278 case x of y { I# x' ->
279 case p of q { I# p' -> ... } }
280 These are, in effect, just strict let's, with pattern matching.
281 With -dppr-case-as-let we print them as such:
282 let! { I# x' ~ y <- x } in
283 let! { I# p' ~ q <- p } in ...
284
285
286 Other printing bits-and-bobs used with the general @pprCoreBinding@
287 and @pprCoreExpr@ functions.
288 -}
289
290 instance OutputableBndr Var where
291 pprBndr = pprCoreBinder
292 pprInfixOcc = pprInfixName . varName
293 pprPrefixOcc = pprPrefixName . varName
294
295 pprCoreBinder :: BindingSite -> Var -> SDoc
296 pprCoreBinder LetBind binder
297 | isTyVar binder = pprKindedTyVarBndr binder
298 | otherwise = pprTypedLetBinder binder $$
299 ppIdInfo binder (idInfo binder)
300
301 -- Lambda bound type variables are preceded by "@"
302 pprCoreBinder bind_site bndr
303 = getPprStyle $ \ sty ->
304 pprTypedLamBinder bind_site (debugStyle sty) bndr
305
306 pprUntypedBinder :: Var -> SDoc
307 pprUntypedBinder binder
308 | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
309 | otherwise = pprIdBndr binder
310
311 pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
312 -- For lambda and case binders, show the unfolding info (usually none)
313 pprTypedLamBinder bind_site debug_on var
314 = sdocWithDynFlags $ \dflags ->
315 case () of
316 _
317 | not debug_on -- Even dead binders can be one-shot
318 , isDeadBinder var -> char '_' <+> ppWhen (isId var)
319 (pprIdBndrInfo (idInfo var))
320
321 | not debug_on -- No parens, no kind info
322 , CaseBind <- bind_site -> pprUntypedBinder var
323
324 | suppress_sigs dflags -> pprUntypedBinder var
325
326 | isTyVar var -> parens (pprKindedTyVarBndr var)
327
328 | otherwise -> parens (hang (pprIdBndr var)
329 2 (vcat [ dcolon <+> pprType (idType var)
330 , pp_unf]))
331 where
332 suppress_sigs = gopt Opt_SuppressTypeSignatures
333
334 unf_info = unfoldingInfo (idInfo var)
335 pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
336 | otherwise = empty
337
338 pprTypedLetBinder :: Var -> SDoc
339 -- Print binder with a type or kind signature (not paren'd)
340 pprTypedLetBinder binder
341 = sdocWithDynFlags $ \dflags ->
342 case () of
343 _
344 | isTyVar binder -> pprKindedTyVarBndr binder
345 | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder
346 | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
347
348 pprKindedTyVarBndr :: TyVar -> SDoc
349 -- Print a type variable binder with its kind (but not if *)
350 pprKindedTyVarBndr tyvar
351 = ptext (sLit "@") <+> pprTvBndr tyvar
352
353 -- pprIdBndr does *not* print the type
354 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
355 pprIdBndr :: Id -> SDoc
356 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
357
358 pprIdBndrInfo :: IdInfo -> SDoc
359 pprIdBndrInfo info
360 = sdocWithDynFlags $ \dflags ->
361 ppUnless (gopt Opt_SuppressIdInfo dflags) $
362 info `seq` doc -- The seq is useful for poking on black holes
363 where
364 prag_info = inlinePragInfo info
365 occ_info = occInfo info
366 dmd_info = demandInfo info
367 lbv_info = oneShotInfo info
368
369 has_prag = not (isDefaultInlinePragma prag_info)
370 has_occ = not (isNoOcc occ_info)
371 has_dmd = not $ isTopDmd dmd_info
372 has_lbv = not (hasNoOneShotInfo lbv_info)
373
374 doc = showAttributes
375 [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
376 , (has_occ, ptext (sLit "Occ=") <> ppr occ_info)
377 , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info)
378 , (has_lbv , ptext (sLit "OS=") <> ppr lbv_info)
379 ]
380
381 {-
382 -----------------------------------------------------
383 -- IdDetails and IdInfo
384 -----------------------------------------------------
385 -}
386
387 ppIdInfo :: Id -> IdInfo -> SDoc
388 ppIdInfo id info
389 = sdocWithDynFlags $ \dflags ->
390 ppUnless (gopt Opt_SuppressIdInfo dflags) $
391 showAttributes
392 [ (True, pp_scope <> ppr (idDetails id))
393 , (has_arity, ptext (sLit "Arity=") <> int arity)
394 , (has_called_arity, ptext (sLit "CallArity=") <> int called_arity)
395 , (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info)
396 , (True, ptext (sLit "Str=") <> pprStrictness str_info)
397 , (has_unf, ptext (sLit "Unf=") <> ppr unf_info)
398 , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
399 ] -- Inline pragma, occ, demand, one-shot info
400 -- printed out with all binders (when debug is on);
401 -- see PprCore.pprIdBndr
402 where
403 pp_scope | isGlobalId id = ptext (sLit "GblId")
404 | isExportedId id = ptext (sLit "LclIdX")
405 | otherwise = ptext (sLit "LclId")
406
407 arity = arityInfo info
408 has_arity = arity /= 0
409
410 called_arity = callArityInfo info
411 has_called_arity = called_arity /= 0
412
413 caf_info = cafInfo info
414 has_caf_info = not (mayHaveCafRefs caf_info)
415
416 str_info = strictnessInfo info
417
418 unf_info = unfoldingInfo info
419 has_unf = hasSomeUnfolding unf_info
420
421 rules = ruleInfoRules (ruleInfo info)
422
423 showAttributes :: [(Bool,SDoc)] -> SDoc
424 showAttributes stuff
425 | null docs = empty
426 | otherwise = brackets (sep (punctuate comma docs))
427 where
428 docs = [d | (True,d) <- stuff]
429
430 {-
431 -----------------------------------------------------
432 -- Unfolding and UnfoldingGuidance
433 -----------------------------------------------------
434 -}
435
436 instance Outputable UnfoldingGuidance where
437 ppr UnfNever = ptext (sLit "NEVER")
438 ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok })
439 = ptext (sLit "ALWAYS_IF") <>
440 parens (ptext (sLit "arity=") <> int arity <> comma <>
441 ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
442 ptext (sLit "boring_ok=") <> ppr boring_ok)
443 ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
444 = hsep [ ptext (sLit "IF_ARGS"),
445 brackets (hsep (map int cs)),
446 int size,
447 int discount ]
448
449 instance Outputable UnfoldingSource where
450 ppr InlineCompulsory = ptext (sLit "Compulsory")
451 ppr InlineStable = ptext (sLit "InlineStable")
452 ppr InlineRhs = ptext (sLit "<vanilla>")
453
454 instance Outputable Unfolding where
455 ppr NoUnfolding = ptext (sLit "No unfolding")
456 ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
457 ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
458 = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\")
459 <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
460 2 (ppr con <+> sep (map ppr args))
461 ppr (CoreUnfolding { uf_src = src
462 , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
463 , uf_is_conlike=conlike, uf_is_work_free=wf
464 , uf_expandable=exp, uf_guidance=g })
465 = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
466 where
467 pp_info = fsep $ punctuate comma
468 [ ptext (sLit "Src=") <> ppr src
469 , ptext (sLit "TopLvl=") <> ppr top
470 , ptext (sLit "Value=") <> ppr hnf
471 , ptext (sLit "ConLike=") <> ppr conlike
472 , ptext (sLit "WorkFree=") <> ppr wf
473 , ptext (sLit "Expandable=") <> ppr exp
474 , ptext (sLit "Guidance=") <> ppr g ]
475 pp_tmpl = sdocWithDynFlags $ \dflags ->
476 ppUnless (gopt Opt_SuppressUnfoldings dflags) $
477 ptext (sLit "Tmpl=") <+> ppr rhs
478 pp_rhs | isStableSource src = pp_tmpl
479 | otherwise = empty
480 -- Don't print the RHS or we get a quadratic
481 -- blowup in the size of the printout!
482
483 {-
484 -----------------------------------------------------
485 -- Rules
486 -----------------------------------------------------
487 -}
488
489 instance Outputable CoreRule where
490 ppr = pprRule
491
492 pprRules :: [CoreRule] -> SDoc
493 pprRules rules = vcat (map pprRule rules)
494
495 pprRule :: CoreRule -> SDoc
496 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
497 = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
498
499 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
500 ru_bndrs = tpl_vars, ru_args = tpl_args,
501 ru_rhs = rhs })
502 = hang (doubleQuotes (ftext name) <+> ppr act)
503 4 (sep [ptext (sLit "forall") <+>
504 sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
505 nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
506 nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
507 ])
508
509 {-
510 -----------------------------------------------------
511 -- Tickish
512 -----------------------------------------------------
513 -}
514
515 instance Outputable id => Outputable (Tickish id) where
516 ppr (HpcTick modl ix) =
517 hcat [ptext (sLit "hpc<"),
518 ppr modl, comma,
519 ppr ix,
520 ptext (sLit ">")]
521 ppr (Breakpoint ix vars) =
522 hcat [ptext (sLit "break<"),
523 ppr ix,
524 ptext (sLit ">"),
525 parens (hcat (punctuate comma (map ppr vars)))]
526 ppr (ProfNote { profNoteCC = cc,
527 profNoteCount = tick,
528 profNoteScope = scope }) =
529 case (tick,scope) of
530 (True,True) -> hcat [ptext (sLit "scctick<"), ppr cc, char '>']
531 (True,False) -> hcat [ptext (sLit "tick<"), ppr cc, char '>']
532 _ -> hcat [ptext (sLit "scc<"), ppr cc, char '>']
533 ppr (SourceNote span _) =
534 hcat [ ptext (sLit "src<"), pprUserRealSpan True span, char '>']
535
536 {-
537 -----------------------------------------------------
538 -- Vectorisation declarations
539 -----------------------------------------------------
540 -}
541
542 instance Outputable CoreVect where
543 ppr (Vect var e) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
544 4 (pprCoreExpr e)
545 ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var
546 ppr (VectType False var Nothing) = ptext (sLit "VECTORISE type") <+> ppr var
547 ppr (VectType True var Nothing) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var
548 ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+>
549 ppr tc
550 ppr (VectType True var (Just tc)) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+>
551 char '=' <+> ppr tc
552 ppr (VectClass tc) = ptext (sLit "VECTORISE class") <+> ppr tc
553 ppr (VectInst var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var