PprCore.lhs 9.57 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The AQUA Project, Glasgow University, 1996-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5
6

Printing of Core syntax
7
8
9

\begin{code}
module PprCore (
10
	pprCoreExpr, pprParendExpr,
11
	pprCoreBinding, pprCoreBindings, pprCoreAlt,
12
	pprRules
13
14
    ) where

15
#include "HsVersions.h"
16
17

import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
18
19
20
21
22
import CostCentre
import Var
import Id
import IdInfo
import NewDemand
23
#ifdef OLD_STRICTNESS
Simon Marlow's avatar
Simon Marlow committed
24
25
import Id
import IdInfo
26
#endif
27

Simon Marlow's avatar
Simon Marlow committed
28
29
30
31
32
33
import DataCon
import TyCon
import Type
import Coercion
import BasicTypes
import Util
34
import Outputable
Simon Marlow's avatar
Simon Marlow committed
35
import FastString
andy@galois.com's avatar
andy@galois.com committed
36
import Module
37
38
39
40
41
42
43
44
45
46
47
\end{code}

%************************************************************************
%*									*
\subsection{Public interfaces for Core printing (excluding instances)}
%*									*
%************************************************************************

@pprParendCoreExpr@ puts parens around non-atomic Core expressions.

\begin{code}
48
49
50
51
pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc
pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc
pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc
52

53
54
pprCoreBindings = pprTopBinds
pprCoreBinding  = pprTopBind 
55

56
57
instance OutputableBndr b => Outputable (Bind b) where
    ppr bind = ppr_bind bind
58

59
60
instance OutputableBndr b => Outputable (Expr b) where
    ppr expr = pprCoreExpr expr
61
\end{code}
62

63
64
65

%************************************************************************
%*									*
66
\subsection{The guts}
67
68
69
70
%*									*
%************************************************************************

\begin{code}
71
pprTopBinds binds = vcat (map pprTopBind binds)
72

73
74
pprTopBind (NonRec binder expr)
 = ppr_binding (binder,expr) $$ text ""
75

76
pprTopBind (Rec binds)
77
  = vcat [ptext SLIT("Rec {"),
78
	  vcat (map ppr_binding binds),
79
80
	  ptext SLIT("end Rec }"),
	  text ""]
81
82
83
\end{code}

\begin{code}
84
ppr_bind :: OutputableBndr b => Bind b -> SDoc
85

86
87
88
89
ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
ppr_bind (Rec binds)  	       = vcat (map pp binds)
			       where
				 pp bind = ppr_binding bind <> semi
90

91
92
93
ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
ppr_binding (val_bdr, expr)
  = pprBndr LetBind val_bdr $$ 
94
    hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
95
96
97
\end{code}

\begin{code}
98
99
pprParendExpr   expr = ppr_expr parens expr
pprCoreExpr expr = ppr_expr noParens expr
100
101
102

noParens :: SDoc -> SDoc
noParens pp = pp
103
104
105
\end{code}

\begin{code}
106
ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
107
108
	-- The function adds parens in context that need
	-- an atomic value (e.g. function args)
109

110
ppr_expr add_par (Type ty)  = add_par (ptext SLIT("TYPE") <+> ppr ty)	-- Wierd
111
	           
112
113
ppr_expr add_par (Var name) = ppr name
ppr_expr add_par (Lit lit)  = ppr lit
114

115
116
117
118
119
ppr_expr add_par (Cast expr co) 
  = add_par $
    sep [pprParendExpr expr, 
	 ptext SLIT("`cast`") <+> parens (pprCo co)]
  where
120
    pprCo co = sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)]
121
122
	 

123
ppr_expr add_par expr@(Lam _ _)
124
  = let
125
	(bndrs, body) = collectBinders expr
126
    in
127
    add_par $
128
129
    hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
	 2 (pprCoreExpr body)
130

131
ppr_expr add_par expr@(App fun arg)
132
133
  = case collectArgs expr of { (fun, args) -> 
    let
134
	pp_args     = sep (map pprArg args)
135
	val_args    = dropWhile isTypeArg args	 -- Drop the type arguments for tuples
136
	pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
137
    in
138
    case fun of
139
	Var f -> case isDataConWorkId_maybe f of
140
141
			-- Notice that we print the *worker*
			-- for tuples in paren'd format.
142
143
144
145
		   Just dc | saturated && isTupleTyCon tc
			   -> tupleParens (tupleTyConBoxity tc) pp_tup_args
			   where
			     tc	       = dataConTyCon dc
sof's avatar
sof committed
146
			     saturated = val_args `lengthIs` idArity f
147

148
		   other -> add_par (hang (ppr f) 2 pp_args)
149

150
	other -> add_par (hang (pprParendExpr fun) 2 pp_args)
151
152
    }

153
ppr_expr add_par (Case expr var ty [(con,args,rhs)])
154
  = add_par $
155
156
    sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
	      ifPprDebug (braces (ppr ty)),
157
158
159
	      sep [ptext SLIT("of") <+> ppr_bndr var, 
		   char '{' <+> ppr_case_pat con args]
	  ],
160
	 pprCoreExpr rhs,
161
162
	 char '}'
    ]
163
  where
164
    ppr_bndr = pprBndr CaseBind
165

166
ppr_expr add_par (Case expr var ty alts)
167
  = add_par $
168
169
170
    sep [sep [ptext SLIT("case")
		<+> pprCoreExpr expr
		<+> ifPprDebug (braces (ppr ty)),
171
	      ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
172
	 nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
173
174
175
	 char '}'
    ]
  where
176
    ppr_bndr = pprBndr CaseBind
177
 
178
179
180
181

-- special cases: let ... in let ...
-- ("disgusting" SLPJ)

182
183
{-
ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
184
185
  = add_par $
    vcat [
186
187
      hsep [ptext SLIT("let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
      nest 2 (pprCoreExpr rhs),
sof's avatar
sof committed
188
      ptext SLIT("} in"),
189
190
      pprCoreExpr body ]
-}
191

192
ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
193
194
  = add_par
    (hang (ptext SLIT("let {"))
195
196
	  2 (hsep [ppr_binding (val_bdr,rhs),
		   ptext SLIT("} in")])
197
     $$
198
     pprCoreExpr expr)
199
200

-- general case (recursive case, too)
201
ppr_expr add_par (Let bind expr)
202
  = add_par $
203
204
    sep [hang (ptext keyword) 2 (ppr_bind bind),
	 hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)]
205
206
  where
    keyword = case bind of
207
		Rec _      -> SLIT("__letrec {")
208
		NonRec _ _ -> SLIT("let {")
209

210
211
ppr_expr add_par (Note (SCC cc) expr)
  = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
212

213
214
ppr_expr add_par (Note InlineMe expr)
  = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
215

216
217
218
219
220
ppr_expr add_par (Note (CoreNote s) expr)
  = add_par $ 
    sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
         pprParendExpr expr]

221
222
pprCoreAlt (con, args, rhs) 
  = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
223

224
ppr_case_pat con@(DataAlt dc) args
225
226
  | isTupleTyCon tc
  = 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
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
232
  = ppr con <+> sep (map ppr_bndr args) <+> arrow
233
  where
234
    ppr_bndr = pprBndr CaseBind
235

236
237
pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
pprArg expr      = pprParendExpr expr
238
239
240
241
242
243
\end{code}

Other printing bits-and-bobs used with the general @pprCoreBinding@
and @pprCoreExpr@ functions.

\begin{code}
244
245
246
247
instance OutputableBndr Var where
  pprBndr = pprCoreBinder

pprCoreBinder :: BindingSite -> Var -> SDoc
248
pprCoreBinder LetBind binder
249
  = vcat [sig, pprIdDetails binder, pragmas]
250
  where
251
    sig     = pprTypedBinder binder
252
    pragmas = ppIdInfo binder (idInfo binder)
253

254
-- Lambda bound type variables are preceded by "@"
255
pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
256

257
258
259
260
261
262
263
-- Case bound things don't get a signature or a herald, unless we have debug on
pprCoreBinder CaseBind bndr 
  = getPprStyle $ \ sty ->
    if debugStyle sty then
	parens (pprTypedBinder bndr)
    else
	pprUntypedBinder bndr
264

265
pprUntypedBinder binder
266
  | isTyVar binder = ptext SLIT("@") <+> ppr binder	-- NB: don't print kind
267
268
  | otherwise      = pprIdBndr binder

269
pprTypedBinder binder
270
  | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
271
  | otherwise	    = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
272

273
274
275
276
277
278
279
280
281
282
283
pprTyVarBndr :: TyVar -> SDoc
pprTyVarBndr tyvar
  = getPprStyle $ \ sty ->
    if debugStyle sty then
        hsep [ppr tyvar, dcolon, pprParendKind kind]
		-- See comments with ppDcolon in PprCore.lhs
    else
        ppr tyvar
  where
    kind = tyVarKind tyvar

284
-- pprIdBndr does *not* print the type
285
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)

pprIdBndrInfo info 
  = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
  where
    prag_info = inlinePragInfo info
    occ_info  = occInfo info
    dmd_info  = newDemandInfo info
    lbv_info  = lbvarInfo info

    no_info = isAlwaysActive prag_info && isNoOcc occ_info && 
	      (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
	      hasNoLBVarInfo lbv_info

    doc | no_info = empty
 	| otherwise
302
        = brackets $ hsep [ppr prag_info, ppr occ_info, 
303
			   ppr dmd_info, ppr lbv_info
304
#ifdef OLD_STRICTNESS
305
			   , ppr (demandInfo id)
306
#endif
307
			  ]
308
\end{code}
309
310
311


\begin{code}
312
313
314
315
316
pprIdDetails :: Id -> SDoc
pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
		| isExportedId id   = ptext SLIT("[Exported]")
		| otherwise	    = empty

317
318
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo b info
319
320
  = brackets $
    vcat [  ppArityInfo a,
321
	    ppWorkerInfo (workerInfo info),
322
	    ppCafInfo (cafInfo info),
323
#ifdef OLD_STRICTNESS
324
	    ppStrictnessInfo s,
325
            ppCprInfo m,
326
#endif
327
	    pprNewStrictness (newStrictnessInfo info),
328
	    if null rules then empty
329
	    else ptext SLIT("RULES:") <+> vcat (map pprRule rules)
330
331
332
	-- Inline pragma, occ, demand, lbvar info
	-- printed out with all binders (when debug is on); 
	-- see PprCore.pprIdBndr
333
334
335
	]
  where
    a = arityInfo info
336
#ifdef OLD_STRICTNESS
337
    s = strictnessInfo info
338
    m = cprInfo info
339
#endif
340
    rules = specInfoRules (specInfo info)
341
342
\end{code}

343

344
\begin{code}
345
346
instance Outputable CoreRule where
   ppr = pprRule
347

348
349
pprRules :: [CoreRule] -> SDoc
pprRules rules = vcat (map pprRule rules)
350

351
352
353
pprRule :: CoreRule -> SDoc
pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
  = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
354

355
356
357
pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
		ru_bndrs = tpl_vars, ru_args = tpl_args,
		ru_rhs = rhs })
358
  = hang (doubleQuotes (ftext name) <+> ppr act)
359
       4 (sep [ptext SLIT("forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
360
361
362
	       nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
	       nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
	    ])
363
\end{code}