root/compiler/coreSyn/PprCore.lhs

Revision 2112f43c466935818a371c53c706608cfa069d01, 16.6 KB (checked in by Simon Peyton Jones <simonpj@…>, 3 weeks ago)

Be a little less aggressive about inlining (fixes Trac #5623)

When inlining, we are making a copy of the expression, so we have to
be careful about duplicating work. Previously we were using
exprIsCheap for that, but it is willing to duplicate a cheap primop --
and that is terribly bad if it happens inside some inner array loop
(Trac #5623). So now we use a new function exprIsWorkFree. Even
then there is some wiggle room:

see Note [exprIsWorkFree] in CoreUtils?

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