tyops
[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 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module PprCore (
17         pprCoreExpr, pprParendExpr,
18         pprCoreBinding, pprCoreBindings, pprCoreAlt,
19         pprRules
20     ) where
21
22 import CoreSyn
23 import Literal( pprLiteral )
24 import Name( pprInfixName, pprPrefixName )
25 import Var
26 import Id
27 import IdInfo
28 import Demand
29 import DataCon
30 import TyCon
31 import Type
32 import Kind
33 import Coercion
34 import StaticFlags
35 import BasicTypes
36 import Util
37 import Outputable
38 import FastString
39 import Data.Maybe
40 \end{code}
41
42 %************************************************************************
43 %*                                                                      *
44 \subsection{Public interfaces for Core printing (excluding instances)}
45 %*                                                                      *
46 %************************************************************************
47
48 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
49
50 \begin{code}
51 pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
52 pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc
53 pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc
54 pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc
55
56 pprCoreBindings = pprTopBinds
57 pprCoreBinding  = pprTopBind 
58
59 instance OutputableBndr b => Outputable (Bind b) where
60     ppr bind = ppr_bind bind
61
62 instance OutputableBndr b => Outputable (Expr b) where
63     ppr expr = pprCoreExpr expr
64 \end{code}
65
66
67 %************************************************************************
68 %*                                                                      *
69 \subsection{The guts}
70 %*                                                                      *
71 %************************************************************************
72
73 \begin{code}
74 pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc
75 pprTopBinds binds = vcat (map pprTopBind binds)
76
77 pprTopBind :: OutputableBndr a => Bind a -> SDoc
78 pprTopBind (NonRec binder expr)
79  = ppr_binding (binder,expr) $$ blankLine
80
81 pprTopBind (Rec [])
82   = ptext (sLit "Rec { }")
83 pprTopBind (Rec (b:bs))
84   = vcat [ptext (sLit "Rec {"),
85           ppr_binding b,
86           vcat [blankLine $$ ppr_binding b | b <- bs],
87           ptext (sLit "end Rec }"),
88           blankLine]
89 \end{code}
90
91 \begin{code}
92 ppr_bind :: OutputableBndr b => Bind b -> SDoc
93
94 ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
95 ppr_bind (Rec binds)           = vcat (map pp binds)
96                                where
97                                  pp bind = ppr_binding bind <> semi
98
99 ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
100 ppr_binding (val_bdr, expr)
101   = pprBndr LetBind val_bdr $$ 
102     hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
103 \end{code}
104
105 \begin{code}
106 pprParendExpr expr = ppr_expr parens expr
107 pprCoreExpr   expr = ppr_expr noParens expr
108
109 noParens :: SDoc -> SDoc
110 noParens pp = pp
111 \end{code}
112
113 \begin{code}
114 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
115         -- The function adds parens in context that need
116         -- an atomic value (e.g. function args)
117
118 ppr_expr _       (Var name)    = ppr name
119 ppr_expr add_par (Type ty)     = add_par (ptext (sLit "TYPE") <+> ppr ty)       -- Wierd
120 ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
121 ppr_expr add_par (Lit lit)     = pprLiteral add_par lit
122
123 ppr_expr add_par (Cast expr co) 
124   = add_par $
125     sep [pprParendExpr expr, 
126          ptext (sLit "`cast`") <+> pprCo co]
127   where
128     pprCo co | opt_SuppressCoercions = ptext (sLit "...")
129              | otherwise = parens
130                          $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
131          
132
133 ppr_expr add_par expr@(Lam _ _)
134   = let
135         (bndrs, body) = collectBinders expr
136     in
137     add_par $
138     hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
139          2 (pprCoreExpr body)
140
141 ppr_expr add_par expr@(App {})
142   = case collectArgs expr of { (fun, args) -> 
143     let
144         pp_args     = sep (map pprArg args)
145         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
146         pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
147     in
148     case fun of
149         Var f -> case isDataConWorkId_maybe f of
150                         -- Notice that we print the *worker*
151                         -- for tuples in paren'd format.
152                    Just dc | saturated && isTupleTyCon tc
153                            -> tupleParens (tupleTyConSort tc) pp_tup_args
154                            where
155                              tc        = dataConTyCon dc
156                              saturated = val_args `lengthIs` idArity f
157
158                    _ -> add_par (hang (ppr f) 2 pp_args)
159
160         _ -> add_par (hang (pprParendExpr fun) 2 pp_args)
161     }
162
163 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
164   | opt_PprCaseAsLet
165   = add_par $
166     sep [sep    [ ptext (sLit "let")
167                         <+> char '{'
168                         <+> ppr_case_pat con args 
169                         <+> ptext (sLit "~")
170                         <+> ppr_bndr var
171                 , ptext (sLit "<-") 
172                         <+> ppr_expr id expr
173                 , char '}' 
174                         <+> ptext (sLit "in")
175                 ]
176         , pprCoreExpr rhs
177         ]
178
179   | otherwise
180   = add_par $
181     sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
182               ifPprDebug (braces (ppr ty)),
183               sep [ptext (sLit "of") <+> ppr_bndr var, 
184                    char '{' <+> ppr_case_pat con args <+> arrow]
185           ],
186          pprCoreExpr rhs,
187          char '}'
188     ]
189   where
190     ppr_bndr = pprBndr CaseBind
191
192 ppr_expr add_par (Case expr var ty alts)
193   = add_par $
194     sep [sep [ptext (sLit "case")
195                 <+> pprCoreExpr expr
196                 <+> ifPprDebug (braces (ppr ty)),
197               ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
198          nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
199          char '}'
200     ]
201   where
202     ppr_bndr = pprBndr CaseBind
203  
204
205 -- special cases: let ... in let ...
206 -- ("disgusting" SLPJ)
207
208 {-
209 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
210   = add_par $
211     vcat [
212       hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
213       nest 2 (pprCoreExpr rhs),
214       ptext (sLit "} in"),
215       pprCoreExpr body ]
216
217 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
218   = add_par
219     (hang (ptext (sLit "let {"))
220           2 (hsep [ppr_binding (val_bdr,rhs),
221                    ptext (sLit "} in")])
222      $$
223      pprCoreExpr expr)
224 -}
225
226 -- General case (recursive case, too)
227 ppr_expr add_par (Let bind expr)
228   = add_par $
229     sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")),
230          pprCoreExpr expr]
231   where
232     keyword = case bind of
233                 Rec _      -> (sLit "letrec {")
234                 NonRec _ _ -> (sLit "let {")
235
236 ppr_expr add_par (Tick tickish expr)
237   = add_par (sep [ppr tickish, pprCoreExpr expr])
238
239 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
240 pprCoreAlt (con, args, rhs) 
241   = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)
242
243 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
244 ppr_case_pat (DataAlt dc) args
245   | isTupleTyCon tc
246   = tupleParens (tupleTyConSort tc) (hsep (punctuate comma (map ppr_bndr args)))
247   where
248     ppr_bndr = pprBndr CaseBind
249     tc = dataConTyCon dc
250
251 ppr_case_pat con args
252   = ppr con <+> sep (map ppr_bndr args)
253   where
254     ppr_bndr = pprBndr CaseBind
255
256
257 -- | Pretty print the argument in a function application.
258 pprArg :: OutputableBndr a => Expr a -> SDoc
259 pprArg (Type ty) 
260  | opt_SuppressTypeApplications = empty
261  | otherwise                    = ptext (sLit "@") <+> pprParendType ty
262 pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
263 pprArg expr          = pprParendExpr expr
264 \end{code}
265
266 Other printing bits-and-bobs used with the general @pprCoreBinding@
267 and @pprCoreExpr@ functions.
268
269 \begin{code}
270 instance OutputableBndr Var where
271   pprBndr = pprCoreBinder
272   pprInfixOcc  = pprInfixName  . varName
273   pprPrefixOcc = pprPrefixName . varName
274
275 pprCoreBinder :: BindingSite -> Var -> SDoc
276 pprCoreBinder LetBind binder
277   | isTyVar binder = pprKindedTyVarBndr binder
278   | otherwise      = pprTypedLetBinder binder $$ 
279                      ppIdInfo binder (idInfo binder)
280
281 -- Lambda bound type variables are preceded by "@"
282 pprCoreBinder bind_site bndr 
283   = getPprStyle $ \ sty ->
284     pprTypedLamBinder bind_site (debugStyle sty) bndr
285
286 pprUntypedBinder :: Var -> SDoc
287 pprUntypedBinder binder
288   | isTyVar binder = ptext (sLit "@") <+> ppr binder    -- NB: don't print kind
289   | otherwise      = pprIdBndr binder
290
291 pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
292 -- For lambda and case binders, show the unfolding info (usually none)
293 pprTypedLamBinder bind_site debug_on var
294   | not debug_on && isDeadBinder var    = char '_'
295   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
296   | opt_SuppressAll                     = pprUntypedBinder var  -- Suppress the signature
297   | isTyVar var                         = parens (pprKindedTyVarBndr var)
298   | otherwise = parens (hang (pprIdBndr var) 
299                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
300   where
301     unf_info = unfoldingInfo (idInfo var)
302     pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
303            | otherwise                 = empty
304
305 pprTypedLetBinder :: Var -> SDoc
306 -- Print binder with a type or kind signature (not paren'd)
307 pprTypedLetBinder binder
308   | isTyVar binder             = pprKindedTyVarBndr binder
309   | opt_SuppressTypeSignatures = pprIdBndr binder
310   | otherwise                  = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
311
312 pprKindedTyVarBndr :: TyVar -> SDoc
313 -- Print a type variable binder with its kind (but not if *)
314 pprKindedTyVarBndr tyvar
315   = ptext (sLit "@") <+> ppr tyvar <> opt_kind
316   where
317     opt_kind    -- Print the kind if not *
318         | isLiftedTypeKind kind = empty
319         | otherwise = dcolon <> pprKind kind
320     kind = tyVarKind tyvar
321
322 -- pprIdBndr does *not* print the type
323 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
324 pprIdBndr :: Id -> SDoc
325 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
326
327 pprIdBndrInfo :: IdInfo -> SDoc
328 pprIdBndrInfo info 
329   | opt_SuppressIdInfo = empty
330   | otherwise
331   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
332   where
333     prag_info = inlinePragInfo info
334     occ_info  = occInfo info
335     dmd_info  = demandInfo info
336     lbv_info  = lbvarInfo info
337
338     has_prag = not (isDefaultInlinePragma prag_info)
339     has_occ  = not (isNoOcc occ_info)
340     has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
341     has_lbv  = not (hasNoLBVarInfo lbv_info)
342
343     doc = showAttributes 
344           [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
345           , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
346           , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
347           , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
348           ]
349 \end{code}
350
351
352 -----------------------------------------------------
353 --      IdDetails and IdInfo
354 -----------------------------------------------------
355
356 \begin{code}
357 ppIdInfo :: Id -> IdInfo -> SDoc
358 ppIdInfo id info
359   | opt_SuppressIdInfo  = empty
360   | otherwise
361   = showAttributes
362     [ (True, pp_scope <> ppr (idDetails id))
363     , (has_arity,      ptext (sLit "Arity=") <> int arity)
364     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
365     , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
366     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
367     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
368     ]   -- Inline pragma, occ, demand, lbvar info
369         -- printed out with all binders (when debug is on); 
370         -- see PprCore.pprIdBndr
371   where
372     pp_scope | isGlobalId id   = ptext (sLit "GblId")
373              | isExportedId id = ptext (sLit "LclIdX")
374              | otherwise       = ptext (sLit "LclId")
375
376     arity = arityInfo info
377     has_arity = arity /= 0
378
379     caf_info = cafInfo info
380     has_caf_info = not (mayHaveCafRefs caf_info)
381
382     str_info = strictnessInfo info
383     has_strictness = isJust str_info
384
385     unf_info = unfoldingInfo info
386     has_unf = hasSomeUnfolding unf_info
387
388     rules = specInfoRules (specInfo info)
389
390 showAttributes :: [(Bool,SDoc)] -> SDoc
391 showAttributes stuff 
392   | null docs = empty
393   | otherwise = brackets (sep (punctuate comma docs))
394   where
395     docs = [d | (True,d) <- stuff]
396 \end{code}
397
398 -----------------------------------------------------
399 --      Unfolding and UnfoldingGuidance
400 -----------------------------------------------------
401
402 \begin{code}
403 instance Outputable UnfoldingGuidance where
404     ppr UnfNever  = ptext (sLit "NEVER")
405     ppr (UnfWhen unsat_ok boring_ok)
406       = ptext (sLit "ALWAYS_IF") <> 
407         parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
408                 ptext (sLit "boring_ok=") <> ppr boring_ok)
409     ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
410       = hsep [ ptext (sLit "IF_ARGS"), 
411                brackets (hsep (map int cs)),
412                int size,
413                int discount ]
414
415 instance Outputable UnfoldingSource where
416   ppr InlineCompulsory  = ptext (sLit "Compulsory")
417   ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
418   ppr InlineStable      = ptext (sLit "InlineStable")
419   ppr InlineRhs         = ptext (sLit "<vanilla>")
420
421 instance Outputable Unfolding where
422   ppr NoUnfolding                = ptext (sLit "No unfolding")
423   ppr (OtherCon cs)              = ptext (sLit "OtherCon") <+> ppr cs
424   ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)  
425                                    <+> ppr con <+> brackets (pprWithCommas ppr ops)
426   ppr (CoreUnfolding { uf_src = src
427                      , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
428                      , uf_is_conlike=conlike, uf_is_cheap=cheap
429                      , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) 
430         = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
431     where
432       pp_info = fsep $ punctuate comma 
433                 [ ptext (sLit "Src=")        <> ppr src
434                 , ptext (sLit "TopLvl=")     <> ppr top 
435                 , ptext (sLit "Arity=")      <> int arity
436                 , ptext (sLit "Value=")      <> ppr hnf
437                 , ptext (sLit "ConLike=")    <> ppr conlike
438                 , ptext (sLit "Cheap=")      <> ppr cheap
439                 , ptext (sLit "Expandable=") <> ppr exp
440                 , ptext (sLit "Guidance=")   <> ppr g ]
441       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
442       pp_rhs | isStableSource src = pp_tmpl
443              | otherwise          = empty
444             -- Don't print the RHS or we get a quadratic 
445             -- blowup in the size of the printout!
446 \end{code}
447
448 -----------------------------------------------------
449 --      Rules
450 -----------------------------------------------------
451
452 \begin{code}
453 instance Outputable CoreRule where
454    ppr = pprRule
455
456 pprRules :: [CoreRule] -> SDoc
457 pprRules rules = vcat (map pprRule rules)
458
459 pprRule :: CoreRule -> SDoc
460 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
461   = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
462
463 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
464                 ru_bndrs = tpl_vars, ru_args = tpl_args,
465                 ru_rhs = rhs })
466   = hang (doubleQuotes (ftext name) <+> ppr act)
467        4 (sep [ptext (sLit "forall") <+> 
468                   sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
469                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
470                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
471             ])
472 \end{code}
473
474 -----------------------------------------------------
475 --      Tickish
476 -----------------------------------------------------
477
478 \begin{code}
479 instance Outputable id => Outputable (Tickish id) where
480   ppr (HpcTick modl ix) =
481       hcat [ptext (sLit "tick<"),
482             ppr modl, comma,
483             ppr ix,
484             ptext (sLit ">")]
485   ppr (Breakpoint ix vars) =
486       hcat [ptext (sLit "break<"),
487             ppr ix,
488             ptext (sLit ">"),
489             parens (hcat (punctuate comma (map ppr vars)))]
490   ppr (ProfNote { profNoteCC = cc,
491                   profNoteCount = tick,
492                   profNoteScope = scope }) =
493       case (tick,scope) of
494          (True,True)  -> hcat [ptext (sLit "scctick<"), ppr cc, char '>']
495          (True,False) -> hcat [ptext (sLit "tick<"),    ppr cc, char '>']
496          _            -> hcat [ptext (sLit "scc<"),     ppr cc, char '>']
497 \end{code}
498
499 -----------------------------------------------------
500 --      Vectorisation declarations
501 -----------------------------------------------------
502
503 \begin{code}
504 instance Outputable CoreVect where
505   ppr (Vect     var Nothing)         = ptext (sLit "VECTORISE SCALAR") <+> ppr var
506   ppr (Vect     var (Just e))        = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
507                                          4 (pprCoreExpr e)
508   ppr (NoVect   var)                 = ptext (sLit "NOVECTORISE") <+> ppr var
509   ppr (VectType False var Nothing)   = ptext (sLit "VECTORISE type") <+> ppr var
510   ppr (VectType True  var Nothing)   = ptext (sLit "VECTORISE SCALAR type") <+> ppr var
511   ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+>
512                                        ppr tc
513   ppr (VectType True var (Just tc))  = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+>
514                                        char '=' <+> ppr tc
515   ppr (VectClass tc)                 = ptext (sLit "VECTORISE class") <+> ppr tc
516   ppr (VectInst var)                 = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var
517 \end{code}