ghc/compiler/coreSyn/CoreUnfold.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1995
   3 %
   4 \section[CoreUnfold]{Core-syntax functions to do with unfoldings}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CoreUnfold (
  10         calcUnfoldingGuidance,
  11
  12         pprCoreUnfolding,
  13         mentionedInUnfolding
  14
  15     ) where
  16
  17 import AbsPrel          ( primOpCanTriggerGC, PrimOp(..), PrimKind
  18                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  19                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  20                         )
  21 import AbsUniType       ( getMentionedTyConsAndClassesFromUniType,
  22                           getUniDataTyCon, getTyConFamilySize,
  23                           pprParendUniType, Class, TyCon, TyVar,
  24                           UniType, TauType(..)
  25                           IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
  26                           IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
  27                           IF_ATTACK_PRAGMAS(COMMA cmpUniType)
  28                         )
  29 import Bag
  30 import BasicLit         ( isNoRepLit, isLitLitLit, BasicLit(..){-.. is for pragmas-} )
  31 import CgCompInfo       ( uNFOLDING_CHEAP_OP_COST,
  32                           uNFOLDING_DEAR_OP_COST,
  33                           uNFOLDING_NOREP_LIT_COST
  34                         )
  35 import CoreFuns         ( digForLambdas, typeOfCoreExpr )
  36 import CoreSyn          -- mostly re-exporting this stuff
  37 import CostCentre       ( showCostCentre, noCostCentreAttached,
  38                           currentOrSubsumedCosts, ccMentionsId, CostCentre
  39                         )
  40 import Id               ( pprIdInUnfolding, getIdUniType,
  41                           whatsMentionedInId, Id, DataCon(..)
  42                         )
  43 import IdInfo
  44 import Maybes
  45 import Outputable
  46 import PlainCore        ( instCoreExpr )
  47 import Pretty
  48 import SimplEnv         ( UnfoldingGuidance(..) )
  49 import UniqSet
  50 import Unique           ( uniqSupply_u, UniqueSupply )
  51 import Util
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 calcUnfoldingGuidance
  62         :: Bool             -- True <=> OK if _scc_s appear in expr
  63         -> Int              -- bomb out if size gets bigger than this
  64         -> PlainCoreExpr    -- expression to look at
  65         -> UnfoldingGuidance
  66
  67 calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
  68   = let
  69         (ty_binders, val_binders, body) = digForLambdas expr
  70     in
  71     case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of
  72
  73       Nothing                -> UnfoldNever
  74
  75       Just (size, cased_args)
  76         -> let
  77                uf = UnfoldIfGoodArgs
  78                         (length ty_binders)
  79                         (length val_binders)
  80                         [ b `is_elem` cased_args | b <- val_binders ]
  81                         size
  82            in
  83            -- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr))
  84            uf
  85   where
  86     is_elem = isIn "calcUnfoldingGuidance"
  87 \end{code}
  88
  89 \begin{code}
  90 sizeExpr :: Bool            -- True <=> _scc_s OK
  91          -> Int             -- Bomb out if it gets bigger than this
  92          -> [Id]            -- Arguments; we're interested in which of these
  93                             -- get case'd
  94          -> PlainCoreExpr
  95          -> Maybe (Int,     -- Size
  96                    [Id]     -- Subset of args which are cased
  97             )
  98
  99 sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
 100   = size_up expr
 101   where
 102     size_up (CoVar v)        = sizeOne
 103     size_up (CoApp fun arg)  = size_up fun `addSizeN` 1
 104     size_up (CoTyApp fun ty) = size_up fun      -- They're free
 105     size_up (CoLit lit)      = if isNoRepLit lit
 106                                then sizeN uNFOLDING_NOREP_LIT_COST
 107                                else sizeOne
 108
 109     size_up (CoSCC _ (CoCon _ _ _)) = Nothing -- **** HACK *****
 110     size_up (CoSCC lbl body)
 111       = if scc_s_OK then size_up body else Nothing
 112
 113     size_up (CoCon con tys args) = sizeN (length args + 1)
 114     size_up (CoPrim op tys args) = sizeN op_cost -- NB: no charge for PrimOp args
 115       where
 116         op_cost = if primOpCanTriggerGC op
 117                   then uNFOLDING_DEAR_OP_COST
 118                         -- these *tend* to be more expensive;
 119                         -- number chosen to avoid unfolding (HACK)
 120                   else uNFOLDING_CHEAP_OP_COST
 121
 122     size_up (CoLam binders body) = size_up body `addSizeN` length binders
 123     size_up (CoTyLam tyvar body) = size_up body
 124
 125     size_up (CoLet (CoNonRec binder rhs) body)
 126       = size_up rhs
 127                 `addSize`
 128         size_up body
 129                 `addSizeN`
 130         1
 131
 132     size_up (CoLet (CoRec pairs) body)
 133       = foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]
 134                 `addSize`
 135         size_up body
 136                 `addSizeN`
 137         length pairs
 138
 139     size_up (CoCase scrut alts)
 140       = size_up_scrut scrut
 141                 `addSize`
 142         size_up_alts (typeOfCoreExpr scrut) alts
 143             -- We charge for the "case" itself in "size_up_alts"
 144
 145     ------------
 146     size_up_alts scrut_ty (CoAlgAlts alts deflt)
 147       = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
 148                 `addSizeN`
 149         (case (getTyConFamilySize tycon) of { Just n -> n })
 150         -- NB: we charge N for an alg. "case", where N is
 151         -- the number of constructors in the thing being eval'd.
 152         -- (You'll eventually get a "discount" of N if you
 153         -- think the "case" is likely to go away.)
 154       where
 155         size_alg_alt (con,args,rhs) = size_up rhs
 156             -- Don't charge for args, so that wrappers look cheap
 157
 158         (tycon, _, _) = getUniDataTyCon scrut_ty
 159
 160
 161     size_up_alts _ (CoPrimAlts alts deflt)
 162       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
 163             -- *no charge* for a primitive "case"!
 164       where
 165         size_prim_alt (lit,rhs) = size_up rhs
 166
 167     ------------
 168     size_up_deflt CoNoDefault = sizeZero
 169     size_up_deflt (CoBindDefault binder rhs) = size_up rhs
 170
 171     ------------
 172         -- Scrutinees.  There are two things going on here.
 173         -- First, we want to record if we're case'ing an argument
 174         -- Second, we want to charge nothing for the srutinee if it's just
 175         -- a variable.  That way wrapper-like things look cheap.
 176     size_up_scrut (CoVar v) | v `is_elem` args = Just (0, [v])
 177                             | otherwise        = Just (0, [])
 178     size_up_scrut other                        = size_up other
 179
 180     is_elem = isIn "size_up_scrut"
 181
 182     ------------
 183     sizeZero  = Just (0, [])
 184     sizeOne   = Just (1, [])
 185     sizeN n   = Just (n, [])
 186     sizeVar v = Just (0, [v])
 187
 188     addSizeN Nothing _ = Nothing
 189     addSizeN (Just (n, xs)) m
 190       | tot < bOMB_OUT_SIZE = Just (tot, xs)
 191       | otherwise = -- pprTrace "bomb1:" (ppCat [ppInt tot, ppInt bOMB_OUT_SIZE, ppr PprDebug expr])
 192                     Nothing
 193       where
 194         tot = n+m
 195
 196     addSize Nothing _ = Nothing
 197     addSize _ Nothing = Nothing
 198     addSize (Just (n, xs)) (Just (m, ys))
 199       | tot < bOMB_OUT_SIZE = Just (tot, xys)
 200       | otherwise  = -- pprTrace "bomb2:" (ppCat [ppInt tot, ppInt bOMB_OUT_SIZE, ppr PprDebug expr])
 201                      Nothing
 202       where
 203         tot = n+m
 204         xys = xs ++ ys
 205 \end{code}
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 Of course, the main thing we do to unfoldings-for-interfaces is {\em
 214 print} them.  But, while we're at it, we collect info about
 215 ``mentioned'' Ids, etc., etc.---we're going to need this stuff anyway.
 216
 217 %************************************************************************
 218 %*                                                                      *
 219 \subsubsection{Monad stuff for the unfolding-generation game}
 220 %*                                                                      *
 221 %************************************************************************
 222
 223 \begin{code}
 224 type UnfoldM bndr thing
 225         =  IdSet        -- in-scope Ids (passed downwards only)
 226         -> (bndr -> Id) -- to extract an Id from a binder (down only)
 227
 228         -> (Bag Id,     -- mentioned global vars (ditto)
 229             Bag TyCon,  -- ditto, tycons
 230             Bag Class,  -- ditto, classes
 231             Bool)       -- True <=> mentions something litlit-ish
 232
 233         -> (thing, (Bag Id, Bag TyCon, Bag Class, Bool)) -- accumulated...
 234 \end{code}
 235
 236 A little stuff for in-scopery:
 237 \begin{code}
 238 no_in_scopes :: IdSet
 239 add1         :: IdSet -> Id   -> IdSet
 240 add_some     :: IdSet -> [Id] -> IdSet
 241
 242 no_in_scopes            = emptyUniqSet
 243 in_scopes `add1`     x  = in_scopes `unionUniqSets` singletonUniqSet x
 244 in_scopes `add_some` xs = in_scopes `unionUniqSets` mkUniqSet xs
 245 \end{code}
 246
 247 The can-see-inside-monad functions are the usual sorts of things.
 248
 249 \begin{code}
 250 thenUf :: UnfoldM bndr a -> (a -> UnfoldM bndr b) -> UnfoldM bndr b
 251 thenUf m k in_scopes get_id mentioneds
 252   = case m in_scopes get_id mentioneds of { (v, mentioneds1) ->
 253     k v in_scopes get_id mentioneds1 }
 254
 255 thenUf_ :: UnfoldM bndr a -> UnfoldM bndr b -> UnfoldM bndr b
 256 thenUf_ m k in_scopes get_id mentioneds
 257   = case m in_scopes get_id mentioneds of { (_, mentioneds1) ->
 258     k in_scopes get_id mentioneds1 }
 259
 260 mapUf :: (a -> UnfoldM bndr b) -> [a] -> UnfoldM bndr [b]
 261 mapUf f []     = returnUf []
 262 mapUf f (x:xs)
 263   = f x         `thenUf` \ r ->
 264     mapUf f xs  `thenUf` \ rs ->
 265     returnUf (r:rs)
 266
 267 returnUf :: a -> UnfoldM bndr a
 268 returnUf v in_scopes get_id mentioneds = (v, mentioneds)
 269
 270 addInScopesUf :: [Id] -> UnfoldM bndr a -> UnfoldM bndr a
 271 addInScopesUf more_in_scopes m in_scopes get_id mentioneds
 272   = m (in_scopes `add_some` more_in_scopes) get_id mentioneds
 273
 274 getInScopesUf :: UnfoldM bndr IdSet
 275 getInScopesUf in_scopes get_id mentioneds = (in_scopes, mentioneds)
 276
 277 extractIdsUf :: [bndr] -> UnfoldM bndr [Id]
 278 extractIdsUf binders in_scopes get_id mentioneds
 279   = (map get_id binders, mentioneds)
 280
 281 consider_Id :: Id -> UnfoldM bndr ()
 282 consider_Id var in_scopes get_id (ids, tcs, clss, has_litlit)
 283   = let
 284         (ids2, tcs2, clss2) = whatsMentionedInId in_scopes var
 285     in
 286     ((), (ids `unionBags` ids2,
 287           tcs `unionBags` tcs2,
 288           clss `unionBags`clss2,
 289           has_litlit))
 290 \end{code}
 291
 292 \begin{code}
 293 addToMentionedIdsUf     :: Id -> UnfoldM bndr ()
 294 addToMentionedTyConsUf  :: Bag TyCon -> UnfoldM bndr ()
 295 addToMentionedClassesUf :: Bag Class -> UnfoldM bndr ()
 296 litlit_oops             :: UnfoldM bndr ()
 297
 298 addToMentionedIdsUf add_me in_scopes get_id (ids, tcs, clss, has_litlit)
 299   = ((), (ids `unionBags` unitBag add_me, tcs, clss, has_litlit))
 300
 301 addToMentionedTyConsUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
 302   = ((), (ids, tcs `unionBags` add_mes, clss, has_litlit))
 303
 304 addToMentionedClassesUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
 305   = ((), (ids, tcs, clss `unionBags` add_mes, has_litlit))
 306
 307 litlit_oops in_scopes get_id (ids, tcs, clss, _)
 308   = ((), (ids, tcs, clss, True))
 309 \end{code}
 310
 311
 312 %************************************************************************
 313 %*                                                                      *
 314 \subsubsection{Gathering up info for an interface-unfolding}
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 \begin{code}
 319 mentionedInUnfolding
 320         :: (bndr -> Id)         -- so we can get Ids out of binders
 321         -> CoreExpr bndr Id     -- input expression
 322         -> ([Id], [TyCon], [Class],
 323                                 -- what we found mentioned in the expr
 324             Bool                -- True <=> mentions a ``litlit''-ish thing
 325                                 -- (the guy on the other side of an interface
 326                                 -- may not be able to handle it)
 327            )
 328
 329 mentionedInUnfolding get_id expr
 330   = case (ment_expr expr no_in_scopes get_id (emptyBag, emptyBag, emptyBag, False)) of
 331       (_, (ids_bag, tcs_bag, clss_bag, has_litlit)) ->
 332         (bagToList ids_bag, bagToList tcs_bag, bagToList clss_bag, has_litlit)
 333 \end{code}
 334
 335 \begin{code}
 336 ment_expr :: CoreExpr bndr Id -> UnfoldM bndr ()
 337
 338 ment_expr (CoVar v) = consider_Id  v
 339 ment_expr (CoLit l) = consider_lit l
 340
 341 ment_expr (CoLam bs body)
 342   = extractIdsUf bs             `thenUf` \ bs_ids ->
 343     addInScopesUf bs_ids (
 344         -- this considering is just to extract any mentioned types/classes
 345         mapUf consider_Id bs_ids   `thenUf_`
 346         ment_expr body
 347     )
 348
 349 ment_expr (CoTyLam _ body) = ment_expr body
 350
 351 ment_expr (CoApp fun arg)
 352   = ment_expr fun       `thenUf_`
 353     ment_atom arg
 354
 355 ment_expr (CoTyApp expr ty)
 356   = ment_ty   ty        `thenUf_`
 357     ment_expr expr
 358
 359 ment_expr (CoCon c ts as)
 360   = consider_Id c       `thenUf_`
 361     mapUf ment_ty ts    `thenUf_`
 362     mapUf ment_atom as  `thenUf_`
 363     returnUf ()
 364
 365 ment_expr (CoPrim op ts as)
 366   = ment_op op          `thenUf_`
 367     mapUf ment_ty   ts  `thenUf_`
 368     mapUf ment_atom as  `thenUf_`
 369     returnUf ()
 370   where
 371     ment_op (CCallOp str is_asm may_gc arg_tys res_ty)
 372       = mapUf ment_ty arg_tys   `thenUf_`
 373         ment_ty res_ty
 374     ment_op other_op = returnUf ()
 375
 376 ment_expr (CoCase scrutinee alts)
 377   = ment_expr scrutinee `thenUf_`
 378     ment_alts alts
 379
 380 ment_expr (CoLet (CoNonRec bind rhs) body)
 381   = ment_expr rhs       `thenUf_`
 382     extractIdsUf [bind] `thenUf` \ bi@[bind_id] ->
 383     addInScopesUf bi    (
 384     ment_expr body      `thenUf_`
 385     consider_Id bind_id )
 386
 387 ment_expr (CoLet (CoRec pairs) body)
 388   = let
 389         binders = map fst pairs
 390         rhss    = map snd pairs
 391     in
 392     extractIdsUf binders        `thenUf` \ binder_ids ->
 393     addInScopesUf binder_ids (
 394         mapUf ment_expr rhss         `thenUf_`
 395         mapUf consider_Id binder_ids `thenUf_`
 396         ment_expr body )
 397
 398 ment_expr (CoSCC cc expr)
 399   = (case (ccMentionsId cc) of
 400       Just id -> consider_Id id
 401       Nothing -> returnUf ()
 402     )
 403     `thenUf_` ment_expr expr
 404
 405 -------------
 406 ment_ty ty
 407   = let
 408         (tycons, clss) = getMentionedTyConsAndClassesFromUniType ty
 409     in
 410     addToMentionedTyConsUf  tycons  `thenUf_`
 411     addToMentionedClassesUf clss
 412
 413 -------------
 414
 415 ment_alts alg_alts@(CoAlgAlts alts deflt)
 416   = mapUf ment_alt alts   `thenUf_`
 417     ment_deflt deflt
 418   where
 419     ment_alt alt@(con, params, rhs)
 420       = consider_Id con         `thenUf_`
 421         extractIdsUf params     `thenUf` \ param_ids ->
 422         addInScopesUf param_ids (
 423           -- "consider" them so we can chk out their types...
 424           mapUf consider_Id param_ids `thenUf_`
 425           ment_expr rhs )
 426
 427 ment_alts (CoPrimAlts alts deflt)
 428   = mapUf ment_alt alts   `thenUf_`
 429     ment_deflt deflt
 430   where
 431     ment_alt alt@(lit, rhs) = ment_expr rhs
 432
 433 ----------------
 434 ment_deflt CoNoDefault
 435   = returnUf ()
 436
 437 ment_deflt d@(CoBindDefault b rhs)
 438   = extractIdsUf [b]            `thenUf` \ bi@[b_id] ->
 439     addInScopesUf bi            (
 440         consider_Id b_id `thenUf_`
 441         ment_expr rhs )
 442
 443 -----------
 444 ment_atom (CoVarAtom v) = consider_Id  v
 445 ment_atom (CoLitAtom l) = consider_lit l
 446
 447 -----------
 448 consider_lit lit
 449   | isLitLitLit lit = litlit_oops `thenUf_` returnUf ()
 450   | otherwise       = returnUf ()
 451 \end{code}
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 \subsubsection{Printing unfoldings in interfaces}
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 Printing Core-expression unfoldings is sufficiently delicate that we
 460 give it its own function.
 461 \begin{code}
 462 pprCoreUnfolding
 463         :: PlainCoreExpr
 464         -> Pretty
 465
 466 pprCoreUnfolding expr
 467   = let
 468         (_, renamed) = instCoreExpr uniqSupply_u expr
 469             -- We rename every unfolding with a "steady" unique supply,
 470             -- so that the names won't constantly change.
 471             -- One place we *MUST NOT* use a splittable UniqueSupply!
 472     in
 473     ppr_uf_Expr emptyUniqSet renamed
 474
 475 ppr_Unfolding = PprUnfolding (panic "CoreUnfold:ppr_Unfolding")
 476 \end{code}
 477
 478 \begin{code}
 479 ppr_uf_Expr in_scopes (CoVar v) = pprIdInUnfolding in_scopes v
 480 ppr_uf_Expr in_scopes (CoLit l) = ppr ppr_Unfolding l
 481
 482 ppr_uf_Expr in_scopes (CoCon c ts as)
 483   = ppBesides [ppPStr SLIT("_!_ "), pprIdInUnfolding no_in_scopes c, ppSP,
 484            ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
 485            ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
 486 ppr_uf_Expr in_scopes (CoPrim op ts as)
 487   = ppBesides [ppPStr SLIT("_#_ "), ppr ppr_Unfolding op, ppSP,
 488            ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
 489            ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
 490
 491 ppr_uf_Expr in_scopes (CoLam binders body)
 492   = ppCat [ppChar '\\', ppIntersperse ppSP (map ppr_uf_Binder binders),
 493            ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add_some` binders) body]
 494
 495 ppr_uf_Expr in_scopes (CoTyLam tyvar expr)
 496   = ppCat [ppPStr SLIT("_/\\_"), interppSP ppr_Unfolding (tyvar:tyvars), ppStr "->",
 497            ppr_uf_Expr in_scopes body]
 498   where
 499     (tyvars, body) = collect_tyvars expr
 500
 501     collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, e_after )
 502       where (tyvs, e_after) = collect_tyvars e
 503     collect_tyvars other_e         = ( [], other_e )
 504
 505 ppr_uf_Expr in_scopes expr@(CoApp fun_expr atom)
 506   = let
 507         (fun, args) = collect_args expr []
 508     in
 509     ppCat [ppPStr SLIT("_APP_ "), ppr_uf_Expr in_scopes fun, ppLbrack,
 510            ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) args), ppRbrack]
 511   where
 512     collect_args (CoApp fun arg) args = collect_args fun (arg:args)
 513     collect_args fun             args = (fun, args)
 514
 515 ppr_uf_Expr in_scopes (CoTyApp expr ty)
 516   = ppCat [ppPStr SLIT("_TYAPP_ "), ppr_uf_Expr in_scopes expr,
 517         ppChar '{', pprParendUniType ppr_Unfolding ty, ppChar '}']
 518
 519 ppr_uf_Expr in_scopes (CoCase scrutinee alts)
 520   = ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {",
 521            pp_alts alts, ppChar '}']
 522   where
 523     pp_alts (CoAlgAlts  alts deflt)
 524       = ppCat [ppPStr SLIT("_ALG_"),  ppCat (map pp_alg  alts), pp_deflt deflt]
 525     pp_alts (CoPrimAlts alts deflt)
 526       = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt]
 527
 528     pp_alg (con, params, rhs)
 529       = ppBesides [pprIdInUnfolding no_in_scopes con, ppSP,
 530                    ppIntersperse ppSP (map ppr_uf_Binder params),
 531                    ppPStr SLIT(" -> "), ppr_uf_Expr (in_scopes `add_some` params) rhs, ppSemi]
 532
 533     pp_prim (lit, rhs)
 534       = ppBesides [ppr ppr_Unfolding lit,
 535                    ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi]
 536
 537     pp_deflt CoNoDefault = ppPStr SLIT("_NO_DEFLT_")
 538     pp_deflt (CoBindDefault binder rhs)
 539       = ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "),
 540                    ppr_uf_Expr (in_scopes `add1` binder) rhs]
 541
 542 ppr_uf_Expr in_scopes (CoLet (CoNonRec binder rhs) body)
 543   = ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs,
 544         ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body]
 545
 546 ppr_uf_Expr in_scopes (CoLet (CoRec pairs) body)
 547   = ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs),
 548         ppStr "} in ", ppr_uf_Expr new_in_scopes body]
 549   where
 550     sep = ppBeside ppSemi ppSP
 551     new_in_scopes = in_scopes `add_some` map fst pairs
 552
 553     pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs]
 554
 555 ppr_uf_Expr in_scopes (CoSCC cc body)
 556   = ASSERT(not (noCostCentreAttached cc))
 557     ASSERT(not (currentOrSubsumedCosts cc))
 558     ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ",  ppr_uf_Expr in_scopes body]
 559 \end{code}
 560
 561 \begin{code}
 562 ppr_uf_Binder :: Id -> Pretty
 563 ppr_uf_Binder v
 564   = ppBesides [ppLparen, pprIdInUnfolding (singletonUniqSet v) v, ppPStr SLIT(" :: "),
 565                ppr ppr_Unfolding (getIdUniType v), ppRparen]
 566
 567 ppr_uf_Atom in_scopes (CoLitAtom l) = ppr ppr_Unfolding l
 568 ppr_uf_Atom in_scopes (CoVarAtom v) = pprIdInUnfolding in_scopes v
 569 \end{code}