PprCore.hs 19.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

Printing of Core syntax
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
{-# OPTIONS_GHC -fno-warn-orphans #-}
10
module PprCore (
11 12
        pprCoreExpr, pprParendExpr,
        pprCoreBinding, pprCoreBindings, pprCoreAlt,
13
        pprCoreBindingWithSize, pprCoreBindingsWithSize,
14
        pprRules
15 16 17
    ) where

import CoreSyn
18
import CoreStats (exprStats)
19
import Literal( pprLiteral )
20
import Name( pprInfixName, pprPrefixName )
Simon Marlow's avatar
Simon Marlow committed
21 22 23
import Var
import Id
import IdInfo
24
import Demand
Simon Marlow's avatar
Simon Marlow committed
25 26 27 28
import DataCon
import TyCon
import Type
import Coercion
29
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
30 31
import BasicTypes
import Util
32
import Outputable
Simon Marlow's avatar
Simon Marlow committed
33
import FastString
Peter Wortmann's avatar
Peter Wortmann committed
34
import SrcLoc      ( pprUserRealSpan )
35

Austin Seipp's avatar
Austin Seipp committed
36 37 38
{-
************************************************************************
*                                                                      *
39
\subsection{Public interfaces for Core printing (excluding instances)}
Austin Seipp's avatar
Austin Seipp committed
40 41
*                                                                      *
************************************************************************
42 43

@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
Austin Seipp's avatar
Austin Seipp committed
44
-}
45

46 47 48 49
pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc
pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc
pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc
50

51 52 53 54 55 56 57 58
pprCoreBindings = pprTopBinds noAnn
pprCoreBinding  = pprTopBind noAnn

pprCoreBindingsWithSize :: [CoreBind] -> SDoc
pprCoreBindingWithSize  :: CoreBind  -> SDoc

pprCoreBindingsWithSize = pprTopBinds sizeAnn
pprCoreBindingWithSize = pprTopBind sizeAnn
59

60
instance OutputableBndr b => Outputable (Bind b) where
61
    ppr bind = ppr_bind noAnn bind
62

63 64
instance OutputableBndr b => Outputable (Expr b) where
    ppr expr = pprCoreExpr expr
65

Austin Seipp's avatar
Austin Seipp committed
66 67 68
{-
************************************************************************
*                                                                      *
69
\subsection{The guts}
Austin Seipp's avatar
Austin Seipp committed
70 71 72
*                                                                      *
************************************************************************
-}
73

74 75 76 77 78
-- | A function to produce an annotation for a given right-hand-side
type Annotation b = Expr b -> SDoc

-- | Annotate with the size of the right-hand-side
sizeAnn :: CoreExpr -> SDoc
79
sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e)
80 81 82 83 84 85 86 87 88 89 90

-- | No annotation
noAnn :: Expr b -> SDoc
noAnn _ = empty

pprTopBinds :: OutputableBndr a
            => Annotation a -- ^ generate an annotation to place before the
                            -- binding
            -> [Bind a]     -- ^ bindings to show
            -> SDoc         -- ^ the pretty result
pprTopBinds ann binds = vcat (map (pprTopBind ann) binds)
91

92 93 94
pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind ann (NonRec binder expr)
 = ppr_binding ann (binder,expr) $$ blankLine
95

96
pprTopBind _ (Rec [])
97
  = text "Rec { }"
98
pprTopBind ann (Rec (b:bs))
99
  = vcat [text "Rec {",
100 101
          ppr_binding ann b,
          vcat [blankLine $$ ppr_binding ann b | b <- bs],
102
          text "end Rec }",
103
          blankLine]
104

105
ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc
106

107 108 109 110
ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr)
ppr_bind ann (Rec binds)           = vcat (map pp binds)
                                    where
                                      pp bind = ppr_binding ann bind <> semi
111

112 113 114
ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding ann (val_bdr, expr)
  = ann expr $$ pprBndr LetBind val_bdr $$
115
    hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
116

117 118
pprParendExpr expr = ppr_expr parens expr
pprCoreExpr   expr = ppr_expr noParens expr
119 120 121

noParens :: SDoc -> SDoc
noParens pp = pp
122

123 124 125
pprOptCo :: Coercion -> SDoc
pprOptCo co = sdocWithDynFlags $ \dflags ->
              if gopt Opt_SuppressCoercions dflags
126
              then text "..."
127 128
              else parens (sep [ppr co, dcolon <+> ppr (coercionType co)])

129
ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
130 131
        -- The function adds parens in context that need
        -- an atomic value (e.g. function args)
132

133
ppr_expr _       (Var name)    = ppr name
134 135
ppr_expr add_par (Type ty)     = add_par (text "TYPE:" <+> ppr ty)       -- Weird
ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co)
136
ppr_expr add_par (Lit lit)     = pprLiteral add_par lit
137

138
ppr_expr add_par (Cast expr co)
139
  = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co]
140

141
ppr_expr add_par expr@(Lam _ _)
142
  = let
143
        (bndrs, body) = collectBinders expr
144
    in
145
    add_par $
146
    hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
147
         2 (pprCoreExpr body)
148

Ian Lynagh's avatar
Ian Lynagh committed
149
ppr_expr add_par expr@(App {})
150 151
  = sdocWithDynFlags $ \dflags ->
    case collectArgs expr of { (fun, args) ->
152
    let
153 154
        pp_args     = sep (map pprArg args)
        val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
155
        pp_tup_args = pprWithCommas pprCoreExpr val_args
156 157 158 159 160 161
        args'
          | gopt Opt_SuppressTypeApplications dflags = val_args
          | otherwise = args
        parens
          | null args' = id
          | otherwise  = add_par
162
    in
163
    case fun of
164 165 166
        Var f -> case isDataConWorkId_maybe f of
                        -- Notice that we print the *worker*
                        -- for tuples in paren'd format.
167 168 169
                   Just dc | saturated
                           , Just sort <- tyConTuple_maybe tc
                           -> tupleParens sort pp_tup_args
170 171 172 173
                           where
                             tc        = dataConTyCon dc
                             saturated = val_args `lengthIs` idArity f

174
                   _ -> parens (hang (ppr f) 2 pp_args)
175

176
        _ -> parens (hang (pprParendExpr fun) 2 pp_args)
177 178
    }

179
ppr_expr add_par (Case expr var ty [(con,args,rhs)])
180
  = sdocWithDynFlags $ \dflags ->
ian@well-typed.com's avatar
ian@well-typed.com committed
181
    if gopt Opt_PprCaseAsLet dflags
182
    then add_par $  -- See Note [Print case as let]
183
         sep [ sep [ text "let! {"
184
                     <+> ppr_case_pat con args
185
                     <+> text "~"
186
                     <+> ppr_bndr var
187 188
                   , text "<-" <+> ppr_expr id expr
                     <+> text "} in" ]
189 190 191
             , pprCoreExpr rhs
             ]
    else add_par $
192 193 194 195 196 197 198 199 200
         sep [sep [sep [ text "case" <+> pprCoreExpr expr
                       , ifPprDebug (text "return" <+> ppr ty)
                       , text "of" <+> ppr_bndr var
                       ]
                  , char '{' <+> ppr_case_pat con args <+> arrow
                  ]
              , pprCoreExpr rhs
              , char '}'
              ]
201
  where
202
    ppr_bndr = pprBndr CaseBind
203

204
ppr_expr add_par (Case expr var ty alts)
205
  = add_par $
206
    sep [sep [text "case"
207
                <+> pprCoreExpr expr
208
                <+> ifPprDebug (text "return" <+> ppr ty),
209
              text "of" <+> ppr_bndr var <+> char '{'],
210 211
         nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
         char '}'
212 213
    ]
  where
214
    ppr_bndr = pprBndr CaseBind
215

216 217 218 219

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

220 221
{-
ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
222 223
  = add_par $
    vcat [
224
      hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
225
      nest 2 (pprCoreExpr rhs),
226
      text "} in",
227
      pprCoreExpr body ]
228

229
ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
230
  = add_par
231
    (hang (text "let {")
232
          2 (hsep [ppr_binding (val_bdr,rhs),
233
                   text "} in"])
234
     $$
235
     pprCoreExpr expr)
236
-}
237

238
-- General case (recursive case, too)
239
ppr_expr add_par (Let bind expr)
240
  = add_par $
241
    sep [hang (ptext keyword) 2 (ppr_bind noAnn bind <+> text "} in"),
242
         pprCoreExpr expr]
243 244
  where
    keyword = case bind of
245 246
                Rec _      -> (sLit "letrec {")
                NonRec _ _ -> (sLit "let {")
247

248
ppr_expr add_par (Tick tickish expr)
Peter Wortmann's avatar
Peter Wortmann committed
249 250 251 252
  = sdocWithDynFlags $ \dflags ->
  if gopt Opt_PprShowTicks dflags
  then add_par (sep [ppr tickish, pprCoreExpr expr])
  else ppr_expr add_par expr
253

Ian Lynagh's avatar
Ian Lynagh committed
254
pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
255
pprCoreAlt (con, args, rhs)
256
  = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)
257

Ian Lynagh's avatar
Ian Lynagh committed
258 259
ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat (DataAlt dc) args
260
  | Just sort <- tyConTuple_maybe tc
261
  = tupleParens sort (pprWithCommas ppr_bndr args)
262
  where
263
    ppr_bndr = pprBndr CasePatBind
264
    tc = dataConTyCon dc
265

266
ppr_case_pat con args
267
  = ppr con <+> (fsep (map ppr_bndr args))
268
  where
269
    ppr_bndr = pprBndr CasePatBind
270

benl's avatar
benl committed
271 272

-- | Pretty print the argument in a function application.
Ian Lynagh's avatar
Ian Lynagh committed
273
pprArg :: OutputableBndr a => Expr a -> SDoc
274
pprArg (Type ty)
275
 = sdocWithDynFlags $ \dflags ->
ian@well-typed.com's avatar
ian@well-typed.com committed
276
   if gopt Opt_SuppressTypeApplications dflags
277
   then empty
278 279
   else text "@" <+> pprParendType ty
pprArg (Coercion co) = text "@~" <+> pprOptCo co
280
pprArg expr          = pprParendExpr expr
281

Austin Seipp's avatar
Austin Seipp committed
282
{-
283 284 285
Note [Print case as let]
~~~~~~~~~~~~~~~~~~~~~~~~
Single-branch case expressions are very common:
Austin Seipp's avatar
Austin Seipp committed
286
   case x of y { I# x' ->
287 288 289 290 291 292
   case p of q { I# p' -> ... } }
These are, in effect, just strict let's, with pattern matching.
With -dppr-case-as-let we print them as such:
   let! { I# x' ~ y <- x } in
   let! { I# p' ~ q <- p } in ...

Austin Seipp's avatar
Austin Seipp committed
293

294 295
Other printing bits-and-bobs used with the general @pprCoreBinding@
and @pprCoreExpr@ functions.
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310


Note [Binding-site specific printing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust
the information printed.

Let-bound binders are printed with their full type and idInfo.

Case-bound variables (both the case binder and pattern variables) are printed
without a type and without their unfolding.

Furthermore, a dead case-binder is completely ignored, while otherwise, dead
binders are printed as "_".
Austin Seipp's avatar
Austin Seipp committed
311
-}
312

313 314
instance OutputableBndr Var where
  pprBndr = pprCoreBinder
315 316
  pprInfixOcc  = pprInfixName  . varName
  pprPrefixOcc = pprPrefixName . varName
317 318

pprCoreBinder :: BindingSite -> Var -> SDoc
319
pprCoreBinder LetBind binder
320
  | isTyVar binder = pprKindedTyVarBndr binder
321 322
  | otherwise      = pprTypedLetBinder binder $$
                     ppIdInfo binder (idInfo binder)
323

324
-- Lambda bound type variables are preceded by "@"
325
pprCoreBinder bind_site bndr
326
  = getPprStyle $ \ sty ->
327
    pprTypedLamBinder bind_site (debugStyle sty) bndr
328

Ian Lynagh's avatar
Ian Lynagh committed
329
pprUntypedBinder :: Var -> SDoc
330
pprUntypedBinder binder
331
  | isTyVar binder = text "@" <+> ppr binder    -- NB: don't print kind
332 333
  | otherwise      = pprIdBndr binder

334
pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
335
-- For lambda and case binders, show the unfolding info (usually none)
336
pprTypedLamBinder bind_site debug_on var
337 338 339
  = sdocWithDynFlags $ \dflags ->
    case () of
    _
340 341 342 343
      | not debug_on            -- Show case-bound wild bilders only if debug is on
      , CaseBind <- bind_site
      , isDeadBinder var        -> empty

344 345 346 347 348 349 350
      | not debug_on            -- Even dead binders can be one-shot
      , isDeadBinder var        -> char '_' <+> ppWhen (isId var)
                                                (pprIdBndrInfo (idInfo var))

      | not debug_on            -- No parens, no kind info
      , CaseBind <- bind_site   -> pprUntypedBinder var

351 352 353
      | not debug_on
      , CasePatBind <- bind_site    -> pprUntypedBinder var

354 355 356 357 358 359 360
      | suppress_sigs dflags    -> pprUntypedBinder var

      | isTyVar var  -> parens (pprKindedTyVarBndr var)

      | otherwise    -> parens (hang (pprIdBndr var)
                                   2 (vcat [ dcolon <+> pprType (idType var)
                                           , pp_unf]))
361
  where
362 363
    suppress_sigs = gopt Opt_SuppressTypeSignatures

364
    unf_info = unfoldingInfo (idInfo var)
365
    pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info
366
           | otherwise                 = empty
367

368
pprTypedLetBinder :: Var -> SDoc
369
-- Print binder with a type or kind signature (not paren'd)
370
pprTypedLetBinder binder
371 372 373 374
  = sdocWithDynFlags $ \dflags ->
    case () of
    _
      | isTyVar binder                         -> pprKindedTyVarBndr binder
ian@well-typed.com's avatar
ian@well-typed.com committed
375
      | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder
376
      | otherwise                              -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
377

378 379 380
pprKindedTyVarBndr :: TyVar -> SDoc
-- Print a type variable binder with its kind (but not if *)
pprKindedTyVarBndr tyvar
381
  = text "@" <+> pprTvBndr tyvar
382

383
-- pprIdBndr does *not* print the type
384
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
Ian Lynagh's avatar
Ian Lynagh committed
385
pprIdBndr :: Id -> SDoc
386 387
pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)

Ian Lynagh's avatar
Ian Lynagh committed
388
pprIdBndrInfo :: IdInfo -> SDoc
389
pprIdBndrInfo info
390
  = sdocWithDynFlags $ \dflags ->
391 392
    ppUnless (gopt Opt_SuppressIdInfo dflags) $
    info `seq` doc -- The seq is useful for poking on black holes
393 394 395
  where
    prag_info = inlinePragInfo info
    occ_info  = occInfo info
396
    dmd_info  = demandInfo info
397
    lbv_info  = oneShotInfo info
398

399 400
    has_prag  = not (isDefaultInlinePragma prag_info)
    has_occ   = not (isNoOcc occ_info)
Austin Seipp's avatar
Austin Seipp committed
401
    has_dmd   = not $ isTopDmd dmd_info
402
    has_lbv   = not (hasNoOneShotInfo lbv_info)
403

404
    doc = showAttributes
405 406 407 408
          [ (has_prag, text "InlPrag=" <> ppr prag_info)
          , (has_occ,  text "Occ=" <> ppr occ_info)
          , (has_dmd,  text "Dmd=" <> ppr dmd_info)
          , (has_lbv , text "OS=" <> ppr lbv_info)
409
          ]
410

Austin Seipp's avatar
Austin Seipp committed
411
{-
412
-----------------------------------------------------
413
--      IdDetails and IdInfo
414
-----------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
415
-}
416 417 418

ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo id info
419
  = sdocWithDynFlags $ \dflags ->
420
    ppUnless (gopt Opt_SuppressIdInfo dflags) $
421
    showAttributes
422
    [ (True, pp_scope <> ppr (idDetails id))
423 424 425
    , (has_arity,        text "Arity=" <> int arity)
    , (has_called_arity, text "CallArity=" <> int called_arity)
    , (has_caf_info,     text "Caf=" <> ppr caf_info)
Joachim Breitner's avatar
Joachim Breitner committed
426
    , (has_str_info,     text "Str=" <> pprStrictness str_info)
427 428
    , (has_unf,          text "Unf=" <> ppr unf_info)
    , (not (null rules), text "RULES:" <+> vcat (map pprRule rules))
429
    ]   -- Inline pragma, occ, demand, one-shot info
430 431
        -- printed out with all binders (when debug is on);
        -- see PprCore.pprIdBndr
432
  where
433 434 435
    pp_scope | isGlobalId id   = text "GblId"
             | isExportedId id = text "LclIdX"
             | otherwise       = text "LclId"
436

437 438 439
    arity = arityInfo info
    has_arity = arity /= 0

440 441 442
    called_arity = callArityInfo info
    has_called_arity = called_arity /= 0

443 444 445
    caf_info = cafInfo info
    has_caf_info = not (mayHaveCafRefs caf_info)

446
    str_info = strictnessInfo info
Joachim Breitner's avatar
Joachim Breitner committed
447
    has_str_info = not (isTopSig str_info)
448 449 450 451

    unf_info = unfoldingInfo info
    has_unf = hasSomeUnfolding unf_info

452
    rules = ruleInfoRules (ruleInfo info)
453 454

showAttributes :: [(Bool,SDoc)] -> SDoc
455
showAttributes stuff
456 457 458 459 460
  | null docs = empty
  | otherwise = brackets (sep (punctuate comma docs))
  where
    docs = [d | (True,d) <- stuff]

Austin Seipp's avatar
Austin Seipp committed
461
{-
462
-----------------------------------------------------
463
--      Unfolding and UnfoldingGuidance
464
-----------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
465
-}
466 467

instance Outputable UnfoldingGuidance where
468
    ppr UnfNever  = text "NEVER"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
469
    ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok })
470 471 472 473
      = text "ALWAYS_IF" <>
        parens (text "arity="     <> int arity    <> comma <>
                text "unsat_ok="  <> ppr unsat_ok <> comma <>
                text "boring_ok=" <> ppr boring_ok)
474
    ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
475
      = hsep [ text "IF_ARGS",
476 477 478
               brackets (hsep (map int cs)),
               int size,
               int discount ]
479

480
instance Outputable UnfoldingSource where
481 482 483
  ppr InlineCompulsory  = text "Compulsory"
  ppr InlineStable      = text "InlineStable"
  ppr InlineRhs         = text "<vanilla>"
484

485
instance Outputable Unfolding where
486 487
  ppr NoUnfolding                = text "No unfolding"
  ppr (OtherCon cs)              = text "OtherCon" <+> ppr cs
488
  ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
489
       = hang (text "DFun:" <+> ptext (sLit "\\")
490 491
                <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
            2 (ppr con <+> sep (map ppr args))
492 493
  ppr (CoreUnfolding { uf_src = src
                     , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
494
                     , uf_is_conlike=conlike, uf_is_work_free=wf
Simon Peyton Jones's avatar
Simon Peyton Jones committed
495
                     , uf_expandable=exp, uf_guidance=g })
496
        = text "Unf" <> braces (pp_info $$ pp_rhs)
497
    where
498
      pp_info = fsep $ punctuate comma
499 500 501 502 503 504 505
                [ text "Src="        <> ppr src
                , text "TopLvl="     <> ppr top
                , text "Value="      <> ppr hnf
                , text "ConLike="    <> ppr conlike
                , text "WorkFree="   <> ppr wf
                , text "Expandable=" <> ppr exp
                , text "Guidance="   <> ppr g ]
506 507
      pp_tmpl = sdocWithDynFlags $ \dflags ->
                ppUnless (gopt Opt_SuppressUnfoldings dflags) $
508
                text "Tmpl=" <+> ppr rhs
509 510
      pp_rhs | isStableSource src = pp_tmpl
             | otherwise          = empty
511 512
            -- Don't print the RHS or we get a quadratic
            -- blowup in the size of the printout!
513

Austin Seipp's avatar
Austin Seipp committed
514
{-
515
-----------------------------------------------------
516
--      Rules
517
-----------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
518
-}
519

520 521
instance Outputable CoreRule where
   ppr = pprRule
522

523 524
pprRules :: [CoreRule] -> SDoc
pprRules rules = vcat (map pprRule rules)
525

526 527
pprRule :: CoreRule -> SDoc
pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
528
  = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name)
529

530
pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
531 532
                ru_bndrs = tpl_vars, ru_args = tpl_args,
                ru_rhs = rhs })
533
  = hang (doubleQuotes (ftext name) <+> ppr act)
534
       4 (sep [text "forall" <+>
535
                  sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
536
               nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
537
               nest 2 (text "=" <+> pprCoreExpr rhs)
538 539
            ])

Austin Seipp's avatar
Austin Seipp committed
540
{-
541 542 543
-----------------------------------------------------
--      Tickish
-----------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
544
-}
545 546 547

instance Outputable id => Outputable (Tickish id) where
  ppr (HpcTick modl ix) =
548
      hcat [text "hpc<",
549 550
            ppr modl, comma,
            ppr ix,
551
            text ">"]
552
  ppr (Breakpoint ix vars) =
553
      hcat [text "break<",
554
            ppr ix,
555
            text ">",
556 557 558 559 560
            parens (hcat (punctuate comma (map ppr vars)))]
  ppr (ProfNote { profNoteCC = cc,
                  profNoteCount = tick,
                  profNoteScope = scope }) =
      case (tick,scope) of
561 562 563
         (True,True)  -> hcat [text "scctick<", ppr cc, char '>']
         (True,False) -> hcat [text "tick<",    ppr cc, char '>']
         _            -> hcat [text "scc<",     ppr cc, char '>']
Peter Wortmann's avatar
Peter Wortmann committed
564
  ppr (SourceNote span _) =
565
      hcat [ text "src<", pprUserRealSpan True span, char '>']
566

Austin Seipp's avatar
Austin Seipp committed
567
{-
568 569 570
-----------------------------------------------------
--      Vectorisation declarations
-----------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
571
-}
572 573

instance Outputable CoreVect where
574
  ppr (Vect     var e)               = hang (text "VECTORISE" <+> ppr var <+> char '=')
575
                                         4 (pprCoreExpr e)
576 577 578 579
  ppr (NoVect   var)                 = text "NOVECTORISE" <+> ppr var
  ppr (VectType False var Nothing)   = text "VECTORISE type" <+> ppr var
  ppr (VectType True  var Nothing)   = text "VECTORISE SCALAR type" <+> ppr var
  ppr (VectType False var (Just tc)) = text "VECTORISE type" <+> ppr var <+> char '=' <+>
580
                                       ppr tc
581
  ppr (VectType True var (Just tc))  = text "VECTORISE SCALAR type" <+> ppr var <+>
582
                                       char '=' <+> ppr tc
583 584
  ppr (VectClass tc)                 = text "VECTORISE class" <+> ppr tc
  ppr (VectInst var)                 = text "VECTORISE SCALAR instance" <+> ppr var