VECTORISE pragmas for type classes and instances
[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 Literal( pprLiteral )
18 import Var
19 import Id
20 import IdInfo
21 import Demand
22 import DataCon
23 import TyCon
24 import Type
25 import Coercion
26 import StaticFlags
27 import BasicTypes
28 import Util
29 import Outputable
30 import FastString
31 import Data.Maybe
32 \end{code}
33
34 %************************************************************************
35 %*                                                                      *
36 \subsection{Public interfaces for Core printing (excluding instances)}
37 %*                                                                      *
38 %************************************************************************
39
40 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
41
42 \begin{code}
43 pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
44 pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc
45 pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc
46 pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc
47
48 pprCoreBindings = pprTopBinds
49 pprCoreBinding  = pprTopBind 
50
51 instance OutputableBndr b => Outputable (Bind b) where
52     ppr bind = ppr_bind bind
53
54 instance OutputableBndr b => Outputable (Expr b) where
55     ppr expr = pprCoreExpr expr
56 \end{code}
57
58
59 %************************************************************************
60 %*                                                                      *
61 \subsection{The guts}
62 %*                                                                      *
63 %************************************************************************
64
65 \begin{code}
66 pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc
67 pprTopBinds binds = vcat (map pprTopBind binds)
68
69 pprTopBind :: OutputableBndr a => Bind a -> SDoc
70 pprTopBind (NonRec binder expr)
71  = ppr_binding (binder,expr) $$ blankLine
72
73 pprTopBind (Rec [])
74   = ptext (sLit "Rec { }")
75 pprTopBind (Rec (b:bs))
76   = vcat [ptext (sLit "Rec {"),
77           ppr_binding b,
78           vcat [blankLine $$ ppr_binding b | b <- bs],
79           ptext (sLit "end Rec }"),
80           blankLine]
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 _       (Var name)    = ppr name
111 ppr_expr add_par (Type ty)     = add_par (ptext (sLit "TYPE") <+> ppr ty)       -- Wierd
112 ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
113 ppr_expr add_par (Lit lit)     = pprLiteral add_par 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 <+> pprEqPred (coercionKind 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 (tupleTyConSort 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   | opt_PprCaseAsLet
157   = add_par $
158     sep [sep    [ ptext (sLit "let")
159                         <+> char '{'
160                         <+> ppr_case_pat con args 
161                         <+> ptext (sLit "~")
162                         <+> ppr_bndr var
163                 , ptext (sLit "<-") 
164                         <+> ppr_expr id expr
165                 , char '}' 
166                         <+> ptext (sLit "in")
167                 ]
168         , pprCoreExpr rhs
169         ]
170
171   | otherwise
172   = add_par $
173     sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
174               ifPprDebug (braces (ppr ty)),
175               sep [ptext (sLit "of") <+> ppr_bndr var, 
176                    char '{' <+> ppr_case_pat con args <+> arrow]
177           ],
178          pprCoreExpr rhs,
179          char '}'
180     ]
181   where
182     ppr_bndr = pprBndr CaseBind
183
184 ppr_expr add_par (Case expr var ty alts)
185   = add_par $
186     sep [sep [ptext (sLit "case")
187                 <+> pprCoreExpr expr
188                 <+> ifPprDebug (braces (ppr ty)),
189               ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
190          nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
191          char '}'
192     ]
193   where
194     ppr_bndr = pprBndr CaseBind
195  
196
197 -- special cases: let ... in let ...
198 -- ("disgusting" SLPJ)
199
200 {-
201 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
202   = add_par $
203     vcat [
204       hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
205       nest 2 (pprCoreExpr rhs),
206       ptext (sLit "} in"),
207       pprCoreExpr body ]
208
209 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
210   = add_par
211     (hang (ptext (sLit "let {"))
212           2 (hsep [ppr_binding (val_bdr,rhs),
213                    ptext (sLit "} in")])
214      $$
215      pprCoreExpr expr)
216 -}
217
218 -- General case (recursive case, too)
219 ppr_expr add_par (Let bind expr)
220   = add_par $
221     sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")),
222          pprCoreExpr expr]
223   where
224     keyword = case bind of
225                 Rec _      -> (sLit "letrec {")
226                 NonRec _ _ -> (sLit "let {")
227
228 ppr_expr add_par (Note (SCC cc) expr)
229   = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
230
231 ppr_expr add_par (Note (CoreNote s) expr)
232   = add_par $ 
233     sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
234          pprParendExpr expr]
235
236 pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
237 pprCoreAlt (con, args, rhs) 
238   = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)
239
240 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
241 ppr_case_pat (DataAlt dc) args
242   | isTupleTyCon tc
243   = tupleParens (tupleTyConSort tc) (hsep (punctuate comma (map ppr_bndr args)))
244   where
245     ppr_bndr = pprBndr CaseBind
246     tc = dataConTyCon dc
247
248 ppr_case_pat con args
249   = ppr con <+> sep (map ppr_bndr args)
250   where
251     ppr_bndr = pprBndr CaseBind
252
253
254 -- | Pretty print the argument in a function application.
255 pprArg :: OutputableBndr a => Expr a -> SDoc
256 pprArg (Type ty) 
257  | opt_SuppressTypeApplications = empty
258  | otherwise                    = ptext (sLit "@") <+> pprParendType ty
259 pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
260 pprArg expr          = pprParendExpr expr
261 \end{code}
262
263 Other printing bits-and-bobs used with the general @pprCoreBinding@
264 and @pprCoreExpr@ functions.
265
266 \begin{code}
267 instance OutputableBndr Var where
268   pprBndr = pprCoreBinder
269
270 pprCoreBinder :: BindingSite -> Var -> SDoc
271 pprCoreBinder LetBind binder
272   | isTyVar binder = pprKindedTyVarBndr binder
273   | otherwise      = pprTypedLetBinder binder $$ 
274                      ppIdInfo binder (idInfo binder)
275
276 -- Lambda bound type variables are preceded by "@"
277 pprCoreBinder bind_site bndr 
278   = getPprStyle $ \ sty ->
279     pprTypedLamBinder bind_site (debugStyle sty) 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 pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
287 -- For lambda and case binders, show the unfolding info (usually none)
288 pprTypedLamBinder bind_site debug_on var
289   | not debug_on && isDeadBinder var    = char '_'
290   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
291   | opt_SuppressAll                     = pprUntypedBinder var  -- Suppress the signature
292   | isTyVar var                         = parens (pprKindedTyVarBndr var)
293   | otherwise = parens (hang (pprIdBndr var) 
294                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
295   where
296     unf_info = unfoldingInfo (idInfo var)
297     pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
298            | otherwise                 = empty
299
300 pprTypedLetBinder :: Var -> SDoc
301 -- Print binder with a type or kind signature (not paren'd)
302 pprTypedLetBinder binder
303   | isTyVar binder             = pprKindedTyVarBndr binder
304   | opt_SuppressTypeSignatures = pprIdBndr binder
305   | otherwise                  = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
306
307 pprKindedTyVarBndr :: TyVar -> SDoc
308 -- Print a type variable binder with its kind (but not if *)
309 pprKindedTyVarBndr tyvar
310   = ptext (sLit "@") <+> ppr tyvar <> opt_kind
311   where
312     opt_kind    -- Print the kind if not *
313         | isLiftedTypeKind kind = empty
314         | otherwise = dcolon <> pprKind kind
315     kind = tyVarKind tyvar
316
317 -- pprIdBndr does *not* print the type
318 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
319 pprIdBndr :: Id -> SDoc
320 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
321
322 pprIdBndrInfo :: IdInfo -> SDoc
323 pprIdBndrInfo info 
324   | opt_SuppressIdInfo = empty
325   | otherwise
326   = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
327   where
328     prag_info = inlinePragInfo info
329     occ_info  = occInfo info
330     dmd_info  = demandInfo info
331     lbv_info  = lbvarInfo info
332
333     has_prag = not (isDefaultInlinePragma prag_info)
334     has_occ  = not (isNoOcc occ_info)
335     has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
336     has_lbv  = not (hasNoLBVarInfo lbv_info)
337
338     doc = showAttributes 
339           [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
340           , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
341           , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
342           , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
343           ]
344 \end{code}
345
346
347 -----------------------------------------------------
348 --      IdDetails and IdInfo
349 -----------------------------------------------------
350
351 \begin{code}
352 ppIdInfo :: Id -> IdInfo -> SDoc
353 ppIdInfo id info
354   | opt_SuppressIdInfo  = empty
355   | otherwise
356   = showAttributes
357     [ (True, pp_scope <> ppr (idDetails id))
358     , (has_arity,      ptext (sLit "Arity=") <> int arity)
359     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
360     , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
361     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
362     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
363     ]   -- Inline pragma, occ, demand, lbvar info
364         -- printed out with all binders (when debug is on); 
365         -- see PprCore.pprIdBndr
366   where
367     pp_scope | isGlobalId id   = ptext (sLit "GblId")
368              | isExportedId id = ptext (sLit "LclIdX")
369              | otherwise       = ptext (sLit "LclId")
370
371     arity = arityInfo info
372     has_arity = arity /= 0
373
374     caf_info = cafInfo info
375     has_caf_info = not (mayHaveCafRefs caf_info)
376
377     str_info = strictnessInfo info
378     has_strictness = isJust str_info
379
380     unf_info = unfoldingInfo info
381     has_unf = hasSomeUnfolding unf_info
382
383     rules = specInfoRules (specInfo info)
384
385 showAttributes :: [(Bool,SDoc)] -> SDoc
386 showAttributes stuff 
387   | null docs = empty
388   | otherwise = brackets (sep (punctuate comma docs))
389   where
390     docs = [d | (True,d) <- stuff]
391 \end{code}
392
393 -----------------------------------------------------
394 --      Unfolding and UnfoldingGuidance
395 -----------------------------------------------------
396
397 \begin{code}
398 instance Outputable UnfoldingGuidance where
399     ppr UnfNever  = ptext (sLit "NEVER")
400     ppr (UnfWhen unsat_ok boring_ok)
401       = ptext (sLit "ALWAYS_IF") <> 
402         parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
403                 ptext (sLit "boring_ok=") <> ppr boring_ok)
404     ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
405       = hsep [ ptext (sLit "IF_ARGS"), 
406                brackets (hsep (map int cs)),
407                int size,
408                int discount ]
409
410 instance Outputable UnfoldingSource where
411   ppr InlineCompulsory  = ptext (sLit "Compulsory")
412   ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
413   ppr InlineStable      = ptext (sLit "InlineStable")
414   ppr InlineRhs         = ptext (sLit "<vanilla>")
415
416 instance Outputable Unfolding where
417   ppr NoUnfolding                = ptext (sLit "No unfolding")
418   ppr (OtherCon cs)              = ptext (sLit "OtherCon") <+> ppr cs
419   ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)  
420                                    <+> ppr con <+> brackets (pprWithCommas ppr ops)
421   ppr (CoreUnfolding { uf_src = src
422                      , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
423                      , uf_is_conlike=conlike, uf_is_cheap=cheap
424                      , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) 
425         = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
426     where
427       pp_info = fsep $ punctuate comma 
428                 [ ptext (sLit "Src=")        <> ppr src
429                 , ptext (sLit "TopLvl=")     <> ppr top 
430                 , ptext (sLit "Arity=")      <> int arity
431                 , ptext (sLit "Value=")      <> ppr hnf
432                 , ptext (sLit "ConLike=")    <> ppr conlike
433                 , ptext (sLit "Cheap=")      <> ppr cheap
434                 , ptext (sLit "Expandable=") <> ppr exp
435                 , ptext (sLit "Guidance=")   <> ppr g ]
436       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
437       pp_rhs | isStableSource src = pp_tmpl
438              | otherwise          = empty
439             -- Don't print the RHS or we get a quadratic 
440             -- blowup in the size of the printout!
441 \end{code}
442
443 -----------------------------------------------------
444 --      Rules
445 -----------------------------------------------------
446
447 \begin{code}
448 instance Outputable CoreRule where
449    ppr = pprRule
450
451 pprRules :: [CoreRule] -> SDoc
452 pprRules rules = vcat (map pprRule rules)
453
454 pprRule :: CoreRule -> SDoc
455 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
456   = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
457
458 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
459                 ru_bndrs = tpl_vars, ru_args = tpl_args,
460                 ru_rhs = rhs })
461   = hang (doubleQuotes (ftext name) <+> ppr act)
462        4 (sep [ptext (sLit "forall") <+> 
463                   sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
464                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
465                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
466             ])
467 \end{code}
468
469 -----------------------------------------------------
470 --      Vectorisation declarations
471 -----------------------------------------------------
472
473 \begin{code}
474 instance Outputable CoreVect where
475   ppr (Vect     var Nothing)         = ptext (sLit "VECTORISE SCALAR") <+> ppr var
476   ppr (Vect     var (Just e))        = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
477                                          4 (pprCoreExpr e)
478   ppr (NoVect   var)                 = ptext (sLit "NOVECTORISE") <+> ppr var
479   ppr (VectType False var Nothing)   = ptext (sLit "VECTORISE type") <+> ppr var
480   ppr (VectType True  var Nothing)   = ptext (sLit "VECTORISE SCALAR type") <+> ppr var
481   ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+>
482                                        ppr tc
483   ppr (VectType True var (Just tc))  = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+>
484                                        char '=' <+> ppr tc
485   ppr (VectClass tc)                 = ptext (sLit "VECTORISE class") <+> ppr tc
486   ppr (VectInst False var)           = ptext (sLit "VECTORISE instance") <+> ppr var
487   ppr (VectInst True var)            = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var
488 \end{code}