ghc/compiler/coreSyn/CoreUnfold.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4 \section[CoreUnfold]{Core-syntax unfoldings}
   5
   6 Unfoldings (which can travel across module boundaries) are in Core
   7 syntax (namely @CoreExpr@s).
   8
   9 The type @Unfolding@ sits ``above'' simply-Core-expressions
  10 unfoldings, capturing ``higher-level'' things we know about a binding,
  11 usually things that the simplifier found out (e.g., ``it's a
  12 literal'').  In the corner of a @SimpleUnfolding@ unfolding, you will
  13 find, unsurprisingly, a Core expression.
  14
  15 \begin{code}
  16 #include "HsVersions.h"
  17
  18 module CoreUnfold (
  19         SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
  20
  21         FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
  22
  23         smallEnoughToInline, couldBeSmallEnoughToInline,
  24
  25         mkSimpleUnfolding,
  26         mkMagicUnfolding,
  27         calcUnfoldingGuidance,
  28         mentionedInUnfolding
  29     ) where
  30
  31 IMP_Ubiq()
  32 IMPORT_DELOOPER(IdLoop)  -- for paranoia checking;
  33                  -- and also to get mkMagicUnfoldingFun
  34 IMPORT_DELOOPER(PrelLoop)  -- for paranoia checking
  35
  36 import Bag              ( emptyBag, unitBag, unionBags, Bag )
  37 import CgCompInfo       ( uNFOLDING_CHEAP_OP_COST,
  38                           uNFOLDING_DEAR_OP_COST,
  39                           uNFOLDING_NOREP_LIT_COST
  40                         )
  41 import CoreSyn
  42 import CoreUtils        ( coreExprType )
  43 import CostCentre       ( ccMentionsId )
  44 import Id               ( idType, getIdArity,  isBottomingId,
  45                           SYN_IE(IdSet), GenId{-instances-} )
  46 import PrimOp           ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
  47 import IdInfo           ( arityMaybe, bottomIsGuaranteed )
  48 import Literal          ( isNoRepLit, isLitLitLit )
  49 import Pretty
  50 import TyCon            ( tyConFamilySize )
  51 import Type             ( getAppDataTyConExpandingDicts )
  52 import UniqSet          ( emptyUniqSet, unitUniqSet, mkUniqSet,
  53                           addOneToUniqSet, unionUniqSets
  54                         )
  55 import Usage            ( SYN_IE(UVar) )
  56 import Util             ( isIn, panic, assertPanic )
  57
  58 whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
  59 getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
  60 \end{code}
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \subsection{@Unfolding@ and @UnfoldingGuidance@ types}
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 \begin{code}
  69 data Unfolding
  70   = NoUnfolding
  71   | CoreUnfolding SimpleUnfolding
  72   | MagicUnfolding
  73         Unique                  -- of the Id whose magic unfolding this is
  74         MagicUnfoldingFun
  75
  76
  77 data SimpleUnfolding
  78   = SimpleUnfolding     FormSummary             -- Tells whether the template is a WHNF or bottom
  79                         UnfoldingGuidance       -- Tells about the *size* of the template.
  80                         TemplateOutExpr         -- The template
  81
  82 type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar
  83         -- An OutExpr with occurrence info attached.  This is used as
  84         -- a template in GeneralForms.
  85
  86
  87 mkSimpleUnfolding form guidance    template
  88   = SimpleUnfolding form guidance template
  89
  90 mkMagicUnfolding :: Unique -> Unfolding
  91 mkMagicUnfolding tag  = MagicUnfolding tag (mkMagicUnfoldingFun tag)
  92
  93
  94 data UnfoldingGuidance
  95   = UnfoldNever
  96   | UnfoldAlways                -- There is no "original" definition,
  97                                 -- so you'd better unfold.  Or: something
  98                                 -- so cheap to unfold (e.g., 1#) that
  99                                 -- you should do it absolutely always.
 100
 101   | UnfoldIfGoodArgs    Int     -- if "m" type args
 102                         Int     -- and "n" value args
 103                         [Int]   -- Discount if the argument is evaluated.
 104                                 -- (i.e., a simplification will definitely
 105                                 -- be possible).  One elt of the list per *value* arg.
 106                         Int     -- The "size" of the unfolding; to be elaborated
 107                                 -- later. ToDo
 108 \end{code}
 109
 110 \begin{code}
 111 instance Outputable UnfoldingGuidance where
 112     ppr sty UnfoldAlways        = ppStr "_ALWAYS_"
 113 --    ppr sty EssentialUnfolding        = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
 114     ppr sty (UnfoldIfGoodArgs t v cs size)
 115       = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
 116                if null cs       -- always print *something*
 117                 then ppChar 'X'
 118                 else ppBesides (map (ppStr . show) cs),
 119                ppInt size ]
 120 \end{code}
 121
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsection{Figuring out things about expressions}
 126 %*                                                                      *
 127 %************************************************************************
 128
 129 \begin{code}
 130 data FormSummary
 131   = VarForm             -- Expression is a variable (or scc var, etc)
 132   | ValueForm           -- Expression is a value: i.e. a value-lambda,constructor, or literal
 133   | BottomForm          -- Expression is guaranteed to be bottom. We're more gung
 134                         -- ho about inlining such things, because it can't waste work
 135   | OtherForm           -- Anything else
 136
 137 instance Outputable FormSummary where
 138    ppr sty VarForm    = ppStr "Var"
 139    ppr sty ValueForm  = ppStr "Value"
 140    ppr sty BottomForm = ppStr "Bot"
 141    ppr sty OtherForm  = ppStr "Other"
 142
 143 mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary
 144
 145 mkFormSummary expr
 146   = go (0::Int) expr            -- The "n" is the number of (value) arguments so far
 147   where
 148     go n (Lit _)        = ASSERT(n==0) ValueForm
 149     go n (Con _ _)      = ASSERT(n==0) ValueForm
 150     go n (Prim _ _)     = OtherForm
 151     go n (SCC _ e)      = go n e
 152     go n (Coerce _ _ e) = go n e
 153     go n (Let _ e)      = OtherForm
 154     go n (Case _ _)     = OtherForm
 155
 156     go 0 (Lam (ValBinder x) e) = ValueForm      -- NB: \x.bottom /= bottom!
 157     go n (Lam (ValBinder x) e) = go (n-1) e     -- Applied lambda
 158     go n (Lam other_binder e)  = go n e
 159
 160     go n (App fun arg) | isValArg arg = go (n+1) fun
 161     go n (App fun other_arg)          = go n fun
 162
 163     go n (Var f) | isBottomingId f = BottomForm
 164     go 0 (Var f)                   = VarForm
 165     go n (Var f)                   = case (arityMaybe (getIdArity f)) of
 166                                           Just arity | n < arity -> ValueForm
 167                                           other                  -> OtherForm
 168
 169 whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
 170 whnfOrBottom e = case mkFormSummary e of
 171                         VarForm    -> True
 172                         ValueForm  -> True
 173                         BottomForm -> True
 174                         OtherForm  -> False
 175 \end{code}
 176
 177
 178 \begin{code}
 179 exprSmallEnoughToDup (Con _ _)   = True -- Could check # of args
 180 exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
 181 exprSmallEnoughToDup (Lit lit)   = not (isNoRepLit lit)
 182 exprSmallEnoughToDup expr
 183   = case (collectArgs expr) of { (fun, _, _, vargs) ->
 184     case fun of
 185       Var v | length vargs == 0 -> True
 186       _                         -> False
 187     }
 188
 189 {- LATER:
 190 WAS: MORE CLEVER:
 191 exprSmallEnoughToDup expr  -- for now, just: <var> applied to <args>
 192   = case (collectArgs expr) of { (fun, _, _, vargs) ->
 193     case fun of
 194       Var v -> v /= buildId
 195                  && v /= augmentId
 196                  && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
 197       _       -> False
 198     }
 199 -}
 200 \end{code}
 201 Question (ADR): What is the above used for?  Is a _ccall_ really small
 202 enough?
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 \begin{code}
 211 calcUnfoldingGuidance
 212         :: Bool                 -- True <=> OK if _scc_s appear in expr
 213         -> Int                  -- bomb out if size gets bigger than this
 214         -> CoreExpr             -- expression to look at
 215         -> UnfoldingGuidance
 216
 217 calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
 218   = let
 219         (use_binders, ty_binders, val_binders, body) = collectBinders expr
 220     in
 221     case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of
 222
 223       Nothing                -> UnfoldNever
 224
 225       Just (size, cased_args)
 226         -> let
 227                uf = UnfoldIfGoodArgs
 228                         (length ty_binders)
 229                         (length val_binders)
 230                         (map discount_for val_binders)
 231                         size
 232                discount_for b | b `is_elem` cased_args = tyConFamilySize tycon
 233                               | otherwise              = 0
 234                               where
 235                                 (tycon, _, _) = getAppDataTyConExpandingDicts (idType b)
 236            in
 237            -- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr))
 238            uf
 239   where
 240     is_elem = isIn "calcUnfoldingGuidance"
 241 \end{code}
 242
 243 \begin{code}
 244 sizeExpr :: Bool            -- True <=> _scc_s OK
 245          -> Int             -- Bomb out if it gets bigger than this
 246          -> [Id]            -- Arguments; we're interested in which of these
 247                             -- get case'd
 248          -> CoreExpr
 249          -> Maybe (Int,     -- Size
 250                    [Id]     -- Subset of args which are cased
 251             )
 252
 253 sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
 254   = size_up expr
 255   where
 256     size_up (Var v)        = sizeOne
 257     size_up (App fun arg)  = size_up fun `addSize` size_up_arg arg
 258     size_up (Lit lit)      = if isNoRepLit lit
 259                                then sizeN uNFOLDING_NOREP_LIT_COST
 260                                else sizeOne
 261
 262     size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
 263     size_up (SCC lbl body)
 264       = if scc_s_OK then size_up body else Nothing
 265
 266     size_up (Coerce _ _ body) = size_up body            -- Coercions cost nothing
 267
 268     size_up (Con con args) = -- 1 + # of val args
 269                              sizeN (1 + numValArgs args)
 270     size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
 271       where
 272         op_cost = if primOpCanTriggerGC op
 273                   then uNFOLDING_DEAR_OP_COST
 274                         -- these *tend* to be more expensive;
 275                         -- number chosen to avoid unfolding (HACK)
 276                   else uNFOLDING_CHEAP_OP_COST
 277
 278     size_up expr@(Lam _ _)
 279       = let
 280             (uvars, tyvars, args, body) = collectBinders expr
 281         in
 282         size_up body `addSizeN` length args
 283
 284     size_up (Let (NonRec binder rhs) body)
 285       = size_up rhs
 286                 `addSize`
 287         size_up body
 288                 `addSizeN`
 289         1
 290
 291     size_up (Let (Rec pairs) body)
 292       = foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]
 293                 `addSize`
 294         size_up body
 295                 `addSizeN`
 296         length pairs
 297
 298     size_up (Case scrut alts)
 299       = size_up_scrut scrut
 300                 `addSize`
 301         size_up_alts (coreExprType scrut) alts
 302             -- We charge for the "case" itself in "size_up_alts"
 303
 304     ------------
 305     size_up_arg arg = if isValArg arg then sizeOne else sizeZero{-it's free-}
 306
 307     ------------
 308     size_up_alts scrut_ty (AlgAlts alts deflt)
 309       = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
 310                 `addSizeN` (tyConFamilySize tycon)
 311         -- NB: we charge N for an alg. "case", where N is
 312         -- the number of constructors in the thing being eval'd.
 313         -- (You'll eventually get a "discount" of N if you
 314         -- think the "case" is likely to go away.)
 315       where
 316         size_alg_alt (con,args,rhs) = size_up rhs
 317             -- Don't charge for args, so that wrappers look cheap
 318
 319         (tycon, _, _) = --trace "CoreUnfold.getAppDataTyConExpandingDicts" $
 320                         getAppDataTyConExpandingDicts scrut_ty
 321
 322     size_up_alts _ (PrimAlts alts deflt)
 323       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
 324             -- *no charge* for a primitive "case"!
 325       where
 326         size_prim_alt (lit,rhs) = size_up rhs
 327
 328     ------------
 329     size_up_deflt NoDefault = sizeZero
 330     size_up_deflt (BindDefault binder rhs) = size_up rhs
 331
 332     ------------
 333         -- Scrutinees.  There are two things going on here.
 334         -- First, we want to record if we're case'ing an argument
 335         -- Second, we want to charge nothing for the srutinee if it's just
 336         -- a variable.  That way wrapper-like things look cheap.
 337     size_up_scrut (Var v) | v `is_elem` args = Just (0, [v])
 338                             | otherwise        = Just (0, [])
 339     size_up_scrut other                        = size_up other
 340
 341     is_elem :: Id -> [Id] -> Bool
 342     is_elem = isIn "size_up_scrut"
 343
 344     ------------
 345     sizeZero  = Just (0, [])
 346     sizeOne   = Just (1, [])
 347     sizeN n   = Just (n, [])
 348     sizeVar v = Just (0, [v])
 349
 350     addSizeN Nothing _ = Nothing
 351     addSizeN (Just (n, xs)) m
 352       | tot < bOMB_OUT_SIZE = Just (tot, xs)
 353       | otherwise = Nothing
 354       where
 355         tot = n+m
 356
 357     addSize Nothing _ = Nothing
 358     addSize _ Nothing = Nothing
 359     addSize (Just (n, xs)) (Just (m, ys))
 360       | tot < bOMB_OUT_SIZE = Just (tot, xys)
 361       | otherwise  = Nothing
 362       where
 363         tot = n+m
 364         xys = xs ++ ys
 365 \end{code}
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 We have very limited information about an unfolding expression: (1)~so
 374 many type arguments and so many value arguments expected---for our
 375 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 376 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 377 have at the moment is a Boolean per argument position that says, ``I
 378 will look with great favour on an explicit constructor in this
 379 position.''
 380
 381 Assuming we have enough type- and value arguments (if not, we give up
 382 immediately), then we see if the ``discounted size'' is below some
 383 (semi-arbitrary) threshold.  It works like this: for every argument
 384 position where we're looking for a constructor AND WE HAVE ONE in our
 385 hands, we get a (again, semi-arbitrary) discount [proportion to the
 386 number of constructors in the type being scrutinized].
 387
 388 \begin{code}
 389 smallEnoughToInline :: Int -> Int       -- Constructor discount and size threshold
 390               -> [Bool]                 -- Evaluated-ness of value arguments
 391               -> UnfoldingGuidance
 392               -> Bool                   -- True => unfold it
 393
 394 smallEnoughToInline con_discount size_threshold _ UnfoldAlways = True
 395 smallEnoughToInline con_discount size_threshold _ UnfoldNever  = False
 396 smallEnoughToInline con_discount size_threshold arg_is_evald_s
 397               (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
 398   = n_vals_wanted <= length arg_is_evald_s &&
 399     discounted_size <= size_threshold
 400
 401   where
 402     discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s)
 403
 404     arg_discount no_of_constrs is_evald
 405       | is_evald  = 1 + no_of_constrs * con_discount
 406       | otherwise = 1
 407 \end{code}
 408
 409 We use this one to avoid exporting inlinings that we ``couldn't possibly
 410 use'' on the other side.  Can be overridden w/ flaggery.
 411 Just the same as smallEnoughToInline, except that it has no actual arguments.
 412
 413 \begin{code}
 414 couldBeSmallEnoughToInline :: Int -> Int        -- Constructor discount and size threshold
 415                            -> UnfoldingGuidance
 416                            -> Bool              -- True => unfold it
 417
 418 couldBeSmallEnoughToInline con_discount size_threshold guidance
 419   = smallEnoughToInline con_discount size_threshold (repeat True) guidance
 420 \end{code}
 421
 422 %************************************************************************
 423 %*                                                                      *
 424 \subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces}
 425 %*                                                                      *
 426 %************************************************************************
 427
 428 Of course, the main thing we do to unfoldings-for-interfaces is {\em
 429 print} them.  But, while we're at it, we collect info about
 430 ``mentioned'' Ids, etc., etc.---we're going to need this stuff anyway.
 431
 432 %************************************************************************
 433 %*                                                                      *
 434 \subsubsection{Monad stuff for the unfolding-generation game}
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 \begin{code}
 439 type UnfoldM bndr thing
 440         =  IdSet        -- in-scope Ids (passed downwards only)
 441         -> (bndr -> Id) -- to extract an Id from a binder (down only)
 442
 443         -> (Bag Id,     -- mentioned global vars (ditto)
 444             Bag TyCon,  -- ditto, tycons
 445             Bag Class,  -- ditto, classes
 446             Bool)       -- True <=> mentions something litlit-ish
 447
 448         -> (thing, (Bag Id, Bag TyCon, Bag Class, Bool)) -- accumulated...
 449 \end{code}
 450
 451 A little stuff for in-scopery:
 452 \begin{code}
 453 no_in_scopes :: IdSet
 454 add1         :: IdSet -> Id   -> IdSet
 455 add_some     :: IdSet -> [Id] -> IdSet
 456
 457 no_in_scopes            = emptyUniqSet
 458 in_scopes `add1`     x  = addOneToUniqSet in_scopes x
 459 in_scopes `add_some` xs = in_scopes `unionUniqSets` mkUniqSet xs
 460 \end{code}
 461
 462 The can-see-inside-monad functions are the usual sorts of things.
 463
 464 \begin{code}
 465 thenUf :: UnfoldM bndr a -> (a -> UnfoldM bndr b) -> UnfoldM bndr b
 466 thenUf m k in_scopes get_id mentioneds
 467   = case m in_scopes get_id mentioneds of { (v, mentioneds1) ->
 468     k v in_scopes get_id mentioneds1 }
 469
 470 thenUf_ :: UnfoldM bndr a -> UnfoldM bndr b -> UnfoldM bndr b
 471 thenUf_ m k in_scopes get_id mentioneds
 472   = case m in_scopes get_id mentioneds of { (_, mentioneds1) ->
 473     k in_scopes get_id mentioneds1 }
 474
 475 mapUf :: (a -> UnfoldM bndr b) -> [a] -> UnfoldM bndr [b]
 476 mapUf f []     = returnUf []
 477 mapUf f (x:xs)
 478   = f x         `thenUf` \ r ->
 479     mapUf f xs  `thenUf` \ rs ->
 480     returnUf (r:rs)
 481
 482 returnUf :: a -> UnfoldM bndr a
 483 returnUf v in_scopes get_id mentioneds = (v, mentioneds)
 484
 485 addInScopesUf :: [Id] -> UnfoldM bndr a -> UnfoldM bndr a
 486 addInScopesUf more_in_scopes m in_scopes get_id mentioneds
 487   = m (in_scopes `add_some` more_in_scopes) get_id mentioneds
 488
 489 getInScopesUf :: UnfoldM bndr IdSet
 490 getInScopesUf in_scopes get_id mentioneds = (in_scopes, mentioneds)
 491
 492 extractIdsUf :: [bndr] -> UnfoldM bndr [Id]
 493 extractIdsUf binders in_scopes get_id mentioneds
 494   = (map get_id binders, mentioneds)
 495
 496 consider_Id :: Id -> UnfoldM bndr ()
 497 consider_Id var in_scopes get_id (ids, tcs, clss, has_litlit)
 498   = let
 499         (ids2, tcs2, clss2) = whatsMentionedInId in_scopes var
 500     in
 501     ((), (ids `unionBags` ids2,
 502           tcs `unionBags` tcs2,
 503           clss `unionBags`clss2,
 504           has_litlit))
 505 \end{code}
 506
 507 \begin{code}
 508 addToMentionedIdsUf     :: Id -> UnfoldM bndr ()
 509 addToMentionedTyConsUf  :: Bag TyCon -> UnfoldM bndr ()
 510 addToMentionedClassesUf :: Bag Class -> UnfoldM bndr ()
 511 litlit_oops             :: UnfoldM bndr ()
 512
 513 addToMentionedIdsUf add_me in_scopes get_id (ids, tcs, clss, has_litlit)
 514   = ((), (ids `unionBags` unitBag add_me, tcs, clss, has_litlit))
 515
 516 addToMentionedTyConsUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
 517   = ((), (ids, tcs `unionBags` add_mes, clss, has_litlit))
 518
 519 addToMentionedClassesUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
 520   = ((), (ids, tcs, clss `unionBags` add_mes, has_litlit))
 521
 522 litlit_oops in_scopes get_id (ids, tcs, clss, _)
 523   = ((), (ids, tcs, clss, True))
 524 \end{code}
 525
 526
 527 %************************************************************************
 528 %*                                                                      *
 529 \subsubsection{Gathering up info for an interface-unfolding}
 530 %*                                                                      *
 531 %************************************************************************
 532
 533 \begin{code}
 534 {-
 535 mentionedInUnfolding
 536         :: (bndr -> Id)         -- so we can get Ids out of binders
 537         -> GenCoreExpr bndr Id  -- input expression
 538         -> (Bag Id, Bag TyCon, Bag Class,
 539                                 -- what we found mentioned in the expr
 540             Bool                -- True <=> mentions a ``litlit''-ish thing
 541                                 -- (the guy on the other side of an interface
 542                                 -- may not be able to handle it)
 543            )
 544 -}
 545
 546 mentionedInUnfolding get_id expr
 547   = case (ment_expr expr no_in_scopes get_id (emptyBag, emptyBag, emptyBag, False)) of
 548       (_, (ids_bag, tcs_bag, clss_bag, has_litlit)) ->
 549         (ids_bag, tcs_bag, clss_bag, has_litlit)
 550 \end{code}
 551
 552 \begin{code}
 553 --ment_expr :: GenCoreExpr bndr Id -> UnfoldM bndr ()
 554
 555 ment_expr (Var v) = consider_Id  v
 556 ment_expr (Lit l) = consider_lit l
 557
 558 ment_expr expr@(Lam _ _)
 559   = let
 560         (uvars, tyvars, args, body) = collectBinders expr
 561     in
 562     extractIdsUf args           `thenUf` \ bs_ids ->
 563     addInScopesUf bs_ids (
 564         -- this considering is just to extract any mentioned types/classes
 565         mapUf consider_Id bs_ids   `thenUf_`
 566         ment_expr body
 567     )
 568
 569 ment_expr (App fun arg)
 570   = ment_expr fun       `thenUf_`
 571     ment_arg  arg
 572
 573 ment_expr (Con c as)
 574   = consider_Id c       `thenUf_`
 575     mapUf ment_arg as   `thenUf_`
 576     returnUf ()
 577
 578 ment_expr (Prim op as)
 579   = ment_op op          `thenUf_`
 580     mapUf ment_arg as   `thenUf_`
 581     returnUf ()
 582   where
 583     ment_op (CCallOp str is_asm may_gc arg_tys res_ty)
 584       = mapUf ment_ty arg_tys   `thenUf_`
 585         ment_ty res_ty
 586     ment_op other_op = returnUf ()
 587
 588 ment_expr (Case scrutinee alts)
 589   = ment_expr scrutinee `thenUf_`
 590     ment_alts alts
 591
 592 ment_expr (Let (NonRec bind rhs) body)
 593   = ment_expr rhs       `thenUf_`
 594     extractIdsUf [bind] `thenUf` \ bi@[bind_id] ->
 595     addInScopesUf bi    (
 596     ment_expr body      `thenUf_`
 597     consider_Id bind_id )
 598
 599 ment_expr (Let (Rec pairs) body)
 600   = let
 601         binders = map fst pairs
 602         rhss    = map snd pairs
 603     in
 604     extractIdsUf binders        `thenUf` \ binder_ids ->
 605     addInScopesUf binder_ids (
 606         mapUf ment_expr rhss         `thenUf_`
 607         mapUf consider_Id binder_ids `thenUf_`
 608         ment_expr body )
 609
 610 ment_expr (SCC cc expr)
 611   = (case (ccMentionsId cc) of
 612       Just id -> consider_Id id
 613       Nothing -> returnUf ()
 614     )
 615     `thenUf_` ment_expr expr
 616
 617 ment_expr (Coerce _ _ _) = panic "ment_expr:Coerce"
 618
 619 -------------
 620 ment_ty ty
 621   = let
 622         (tycons, clss) = getMentionedTyConsAndClassesFromType ty
 623     in
 624     addToMentionedTyConsUf  tycons  `thenUf_`
 625     addToMentionedClassesUf clss
 626
 627 -------------
 628
 629 ment_alts alg_alts@(AlgAlts alts deflt)
 630   = mapUf ment_alt alts   `thenUf_`
 631     ment_deflt deflt
 632   where
 633     ment_alt alt@(con, params, rhs)
 634       = consider_Id con         `thenUf_`
 635         extractIdsUf params     `thenUf` \ param_ids ->
 636         addInScopesUf param_ids (
 637           -- "consider" them so we can chk out their types...
 638           mapUf consider_Id param_ids `thenUf_`
 639           ment_expr rhs )
 640
 641 ment_alts (PrimAlts alts deflt)
 642   = mapUf ment_alt alts   `thenUf_`
 643     ment_deflt deflt
 644   where
 645     ment_alt alt@(lit, rhs) = ment_expr rhs
 646
 647 ----------------
 648 ment_deflt NoDefault
 649   = returnUf ()
 650
 651 ment_deflt d@(BindDefault b rhs)
 652   = extractIdsUf [b]            `thenUf` \ bi@[b_id] ->
 653     addInScopesUf bi            (
 654         consider_Id b_id `thenUf_`
 655         ment_expr rhs )
 656
 657 -----------
 658 ment_arg (VarArg   v)  = consider_Id  v
 659 ment_arg (LitArg   l)  = consider_lit l
 660 ment_arg (TyArg    ty) = ment_ty ty
 661 ment_arg (UsageArg _)  = returnUf ()
 662
 663 -----------
 664 consider_lit lit
 665   | isLitLitLit lit = litlit_oops `thenUf_` returnUf ()
 666   | otherwise       = returnUf ()
 667 \end{code}
 668
 669 %************************************************************************
 670 %*                                                                      *
 671 \subsubsection{Printing unfoldings in interfaces}
 672 %*                                                                      *
 673 %************************************************************************
 674
 675 Printing Core-expression unfoldings is sufficiently delicate that we
 676 give it its own function.
 677 \begin{code}
 678 {- OLD:
 679 pprCoreUnfolding
 680         :: CoreExpr
 681         -> Pretty
 682
 683 pprCoreUnfolding expr
 684   = let
 685         (_, renamed) = instCoreExpr uniqSupply_u expr
 686             -- We rename every unfolding with a "steady" unique supply,
 687             -- so that the names won't constantly change.
 688             -- One place we *MUST NOT* use a splittable UniqueSupply!
 689     in
 690     ppr_uf_Expr emptyUniqSet renamed
 691
 692 ppr_Unfolding = PprUnfolding (panic "CoreUnfold:ppr_Unfolding")
 693 \end{code}
 694
 695 \begin{code}
 696 ppr_uf_Expr in_scopes (Var v) = pprIdInUnfolding in_scopes v
 697 ppr_uf_Expr in_scopes (Lit l) = ppr ppr_Unfolding l
 698
 699 ppr_uf_Expr in_scopes (Con c as)
 700   = ppBesides [ppPStr SLIT("_!_ "), pprIdInUnfolding no_in_scopes c, ppSP,
 701            ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
 702            ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
 703 ppr_uf_Expr in_scopes (Prim op as)
 704   = ppBesides [ppPStr SLIT("_#_ "), ppr ppr_Unfolding op, ppSP,
 705            ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
 706            ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
 707
 708 ppr_uf_Expr in_scopes (Lam binder body)
 709   = ppCat [ppChar '\\', ppr_uf_Binder binder,
 710            ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add1` binder) body]
 711
 712 ppr_uf_Expr in_scopes (CoTyLam tyvar expr)
 713   = ppCat [ppPStr SLIT("_/\\_"), interppSP ppr_Unfolding (tyvar:tyvars), ppStr "->",
 714            ppr_uf_Expr in_scopes body]
 715   where
 716     (tyvars, body) = collect_tyvars expr
 717
 718     collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, e_after )
 719       where (tyvs, e_after) = collect_tyvars e
 720     collect_tyvars other_e         = ( [], other_e )
 721
 722 ppr_uf_Expr in_scopes expr@(App fun_expr atom)
 723   = let
 724         (fun, args) = collect_args expr []
 725     in
 726     ppCat [ppPStr SLIT("_APP_ "), ppr_uf_Expr in_scopes fun, ppLbrack,
 727            ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) args), ppRbrack]
 728   where
 729     collect_args (App fun arg) args = collect_args fun (arg:args)
 730     collect_args fun             args = (fun, args)
 731
 732 ppr_uf_Expr in_scopes (CoTyApp expr ty)
 733   = ppCat [ppPStr SLIT("_TYAPP_ "), ppr_uf_Expr in_scopes expr,
 734         ppChar '{', pprParendUniType ppr_Unfolding ty, ppChar '}']
 735
 736 ppr_uf_Expr in_scopes (Case scrutinee alts)
 737   = ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {",
 738            pp_alts alts, ppChar '}']
 739   where
 740     pp_alts (AlgAlts  alts deflt)
 741       = ppCat [ppPStr SLIT("_ALG_"),  ppCat (map pp_alg  alts), pp_deflt deflt]
 742     pp_alts (PrimAlts alts deflt)
 743       = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt]
 744
 745     pp_alg (con, params, rhs)
 746       = ppBesides [pprIdInUnfolding no_in_scopes con, ppSP,
 747                    ppIntersperse ppSP (map ppr_uf_Binder params),
 748                    ppPStr SLIT(" -> "), ppr_uf_Expr (in_scopes `add_some` params) rhs, ppSemi]
 749
 750     pp_prim (lit, rhs)
 751       = ppBesides [ppr ppr_Unfolding lit,
 752                    ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi]
 753
 754     pp_deflt NoDefault = ppPStr SLIT("_NO_DEFLT_")
 755     pp_deflt (BindDefault binder rhs)
 756       = ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "),
 757                    ppr_uf_Expr (in_scopes `add1` binder) rhs]
 758
 759 ppr_uf_Expr in_scopes (Let (NonRec binder rhs) body)
 760   = ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs,
 761         ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body]
 762
 763 ppr_uf_Expr in_scopes (Let (Rec pairs) body)
 764   = ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs),
 765         ppStr "} in ", ppr_uf_Expr new_in_scopes body]
 766   where
 767     sep = ppBeside ppSemi ppSP
 768     new_in_scopes = in_scopes `add_some` map fst pairs
 769
 770     pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs]
 771
 772 ppr_uf_Expr in_scopes (SCC cc body)
 773   = ASSERT(not (noCostCentreAttached cc))
 774     ASSERT(not (currentOrSubsumedCosts cc))
 775     ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ",  ppr_uf_Expr in_scopes body]
 776
 777 ppr_uf_Expr in_scopes (Coerce _ _ _) = panic "ppr_uf_Expr:Coerce"
 778 \end{code}
 779
 780 \begin{code}
 781 ppr_uf_Binder :: Id -> Pretty
 782 ppr_uf_Binder v
 783   = ppBesides [ppLparen, pprIdInUnfolding (unitUniqSet v) v, ppPStr SLIT(" :: "),
 784                ppr ppr_Unfolding (idType v), ppRparen]
 785
 786 ppr_uf_Atom in_scopes (LitArg l) = ppr ppr_Unfolding l
 787 ppr_uf_Atom in_scopes (VarArg v) = pprIdInUnfolding in_scopes v
 788 END OLD -}
 789 \end{code}