Robustify the treatement of DFunUnfolding
[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 _       (Var name) = ppr name
112 ppr_expr _       (Lit lit)  = ppr lit
113
114 ppr_expr add_par (Cast expr co) 
115   = add_par $
116     sep [pprParendExpr expr, 
117          ptext (sLit "`cast`") <+> pprCo co]
118   where
119     pprCo co | opt_SuppressCoercions = ptext (sLit "...")
120              | otherwise = parens
121                          $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
122          
123
124 ppr_expr add_par expr@(Lam _ _)
125   = let
126         (bndrs, body) = collectBinders expr
127     in
128     add_par $
129     hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
130          2 (pprCoreExpr body)
131
132 ppr_expr add_par expr@(App {})
133   = case collectArgs expr of { (fun, args) -> 
134     let
135         pp_args     = sep (map pprArg args)
136         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
137         pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
138     in
139     case fun of
140         Var f -> case isDataConWorkId_maybe f of
141                         -- Notice that we print the *worker*
142                         -- for tuples in paren'd format.
143                    Just dc | saturated && isTupleTyCon tc
144                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
145                            where
146                              tc        = dataConTyCon dc
147                              saturated = val_args `lengthIs` idArity f
148
149                    _ -> add_par (hang (ppr f) 2 pp_args)
150
151         _ -> add_par (hang (pprParendExpr fun) 2 pp_args)
152     }
153
154 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
155   = add_par $
156     sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
157               ifPprDebug (braces (ppr ty)),
158               sep [ptext (sLit "of") <+> ppr_bndr var, 
159                    char '{' <+> ppr_case_pat con args]
160           ],
161          pprCoreExpr rhs,
162          char '}'
163     ]
164   where
165     ppr_bndr = pprBndr CaseBind
166
167 ppr_expr add_par (Case expr var ty alts)
168   = add_par $
169     sep [sep [ptext (sLit "case")
170                 <+> pprCoreExpr expr
171                 <+> ifPprDebug (braces (ppr ty)),
172               ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
173          nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
174          char '}'
175     ]
176   where
177     ppr_bndr = pprBndr CaseBind
178  
179
180 -- special cases: let ... in let ...
181 -- ("disgusting" SLPJ)
182
183 {-
184 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
185   = add_par $
186     vcat [
187       hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
188       nest 2 (pprCoreExpr rhs),
189       ptext (sLit "} in"),
190       pprCoreExpr body ]
191
192 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
193   = add_par
194     (hang (ptext (sLit "let {"))
195           2 (hsep [ppr_binding (val_bdr,rhs),
196                    ptext (sLit "} in")])
197      $$
198      pprCoreExpr expr)
199 -}
200
201 -- General case (recursive case, too)
202 ppr_expr add_par (Let bind expr)
203   = add_par $
204     sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")),
205          pprCoreExpr expr]
206   where
207     keyword = case bind of
208                 Rec _      -> (sLit "letrec {")
209                 NonRec _ _ -> (sLit "let {")
210
211 ppr_expr add_par (Note (SCC cc) expr)
212   = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
213
214 ppr_expr add_par (Note (CoreNote s) expr)
215   = add_par $ 
216     sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
217          pprParendExpr expr]
218
219 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
220 pprCoreAlt (con, args, rhs) 
221   = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
222
223 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
224 ppr_case_pat (DataAlt dc) args
225   | isTupleTyCon tc
226   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
227   where
228     ppr_bndr = pprBndr CaseBind
229     tc = dataConTyCon dc
230
231 ppr_case_pat con args
232   = ppr con <+> sep (map ppr_bndr args) <+> arrow
233   where
234     ppr_bndr = pprBndr CaseBind
235
236 pprArg :: OutputableBndr a => Expr a -> SDoc
237 pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty
238 pprArg expr      = pprParendExpr expr
239 \end{code}
240
241 Other printing bits-and-bobs used with the general @pprCoreBinding@
242 and @pprCoreExpr@ functions.
243
244 \begin{code}
245 instance OutputableBndr Var where
246   pprBndr = pprCoreBinder
247
248 pprCoreBinder :: BindingSite -> Var -> SDoc
249 pprCoreBinder LetBind binder
250   | isTyVar binder = pprKindedTyVarBndr binder
251   | otherwise      = pprTypedBinder binder $$ 
252                      ppIdInfo binder (idInfo binder)
253
254 -- Lambda bound type variables are preceded by "@"
255 pprCoreBinder bind_site bndr 
256   = getPprStyle $ \ sty ->
257     pprTypedLCBinder bind_site (debugStyle sty) bndr
258
259 pprUntypedBinder :: Var -> SDoc
260 pprUntypedBinder binder
261   | isTyVar binder = ptext (sLit "@") <+> ppr binder    -- NB: don't print kind
262   | otherwise      = pprIdBndr binder
263
264 pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
265 -- For lambda and case binders, show the unfolding info (usually none)
266 pprTypedLCBinder bind_site debug_on var
267   | not debug_on && isDeadBinder var    = char '_'
268   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
269   | isTyVar var                         = parens (pprKindedTyVarBndr var)
270   | otherwise = parens (hang (pprIdBndr var) 
271                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
272               where
273                 unf_info = unfoldingInfo (idInfo var)
274                 pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
275                        | otherwise                 = empty
276
277 pprTypedBinder :: Var -> SDoc
278 -- Print binder with a type or kind signature (not paren'd)
279 pprTypedBinder binder
280   | isTyVar binder  = pprKindedTyVarBndr binder
281   | otherwise       = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
282
283 pprKindedTyVarBndr :: TyVar -> SDoc
284 -- Print a type variable binder with its kind (but not if *)
285 pprKindedTyVarBndr tyvar
286   = ptext (sLit "@") <+> ppr tyvar <> opt_kind
287   where
288     opt_kind    -- Print the kind if not *
289         | isLiftedTypeKind kind = empty
290         | otherwise = dcolon <> pprKind kind
291     kind = tyVarKind tyvar
292
293 -- pprIdBndr does *not* print the type
294 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
295 pprIdBndr :: Id -> SDoc
296 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
297
298 pprIdBndrInfo :: IdInfo -> SDoc
299 pprIdBndrInfo info 
300   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
301   where
302     prag_info = inlinePragInfo info
303     occ_info  = occInfo info
304     dmd_info  = demandInfo info
305     lbv_info  = lbvarInfo info
306
307     has_prag = not (isDefaultInlinePragma prag_info)
308     has_occ  = not (isNoOcc occ_info)
309     has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
310     has_lbv  = not (hasNoLBVarInfo lbv_info)
311
312     doc = showAttributes 
313           [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
314           , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
315           , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
316           , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
317           ]
318 \end{code}
319
320
321 -----------------------------------------------------
322 --      IdDetails and IdInfo
323 -----------------------------------------------------
324
325 \begin{code}
326 ppIdInfo :: Id -> IdInfo -> SDoc
327 ppIdInfo id info
328   = showAttributes
329     [ (True, pp_scope <> ppr (idDetails id))
330     , (has_arity,      ptext (sLit "Arity=") <> int arity)
331     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
332     , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
333     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
334     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
335     ]   -- Inline pragma, occ, demand, lbvar info
336         -- printed out with all binders (when debug is on); 
337         -- see PprCore.pprIdBndr
338   where
339     pp_scope | isGlobalId id   = ptext (sLit "GblId")
340              | isExportedId id = ptext (sLit "LclIdX")
341              | otherwise       = ptext (sLit "LclId")
342
343     arity = arityInfo info
344     has_arity = arity /= 0
345
346     caf_info = cafInfo info
347     has_caf_info = not (mayHaveCafRefs caf_info)
348
349     str_info = strictnessInfo info
350     has_strictness = isJust str_info
351
352     unf_info = unfoldingInfo info
353     has_unf = hasSomeUnfolding unf_info
354
355     rules = specInfoRules (specInfo info)
356
357 showAttributes :: [(Bool,SDoc)] -> SDoc
358 showAttributes stuff 
359   | null docs = empty
360   | otherwise = brackets (sep (punctuate comma docs))
361   where
362     docs = [d | (True,d) <- stuff]
363 \end{code}
364
365 -----------------------------------------------------
366 --      Unfolding and UnfoldingGuidance
367 -----------------------------------------------------
368
369 \begin{code}
370 instance Outputable UnfoldingGuidance where
371     ppr UnfNever  = ptext (sLit "NEVER")
372     ppr (UnfWhen unsat_ok boring_ok)
373       = ptext (sLit "ALWAYS_IF") <> 
374         parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
375                 ptext (sLit "boring_ok=") <> ppr boring_ok)
376     ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
377       = hsep [ ptext (sLit "IF_ARGS"), 
378                brackets (hsep (map int cs)),
379                int size,
380                int discount ]
381
382 instance Outputable UnfoldingSource where
383   ppr InlineCompulsory  = ptext (sLit "Compulsory")
384   ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
385   ppr InlineRule        = ptext (sLit "InlineRule")
386   ppr InlineRhs         = ptext (sLit "<vanilla>")
387
388 instance Outputable Unfolding where
389   ppr NoUnfolding                = ptext (sLit "No unfolding")
390   ppr (OtherCon cs)              = ptext (sLit "OtherCon") <+> ppr cs
391   ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)  
392                                    <+> ppr con
393                                    <+> brackets (pprWithCommas pprParendExpr ops)
394   ppr (CoreUnfolding { uf_src = src
395                      , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
396                      , uf_is_conlike=conlike, uf_is_cheap=cheap
397                      , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) 
398         = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
399     where
400       pp_info = fsep $ punctuate comma 
401                 [ ptext (sLit "Src=")        <> ppr src
402                 , ptext (sLit "TopLvl=")     <> ppr top 
403                 , ptext (sLit "Arity=")      <> int arity
404                 , ptext (sLit "Value=")      <> ppr hnf
405                 , ptext (sLit "ConLike=")    <> ppr conlike
406                 , ptext (sLit "Cheap=")      <> ppr cheap
407                 , ptext (sLit "Expandable=") <> ppr exp
408                 , ptext (sLit "Guidance=")   <> ppr g ]
409       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
410       pp_rhs | isInlineRuleSource src = pp_tmpl
411              | otherwise              = empty
412             -- Don't print the RHS or we get a quadratic 
413             -- blowup in the size of the printout!
414 \end{code}
415
416 -----------------------------------------------------
417 --      Rules
418 -----------------------------------------------------
419
420 \begin{code}
421 instance Outputable CoreRule where
422    ppr = pprRule
423
424 pprRules :: [CoreRule] -> SDoc
425 pprRules rules = vcat (map pprRule rules)
426
427 pprRule :: CoreRule -> SDoc
428 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
429   = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
430
431 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
432                 ru_bndrs = tpl_vars, ru_args = tpl_args,
433                 ru_rhs = rhs })
434   = hang (doubleQuotes (ftext name) <+> ppr act)
435        4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
436                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
437                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
438             ])
439 \end{code}