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 @CoreUnfolding@ unfolding, you will
  13 find, unsurprisingly, a Core expression.
  14
  15 \begin{code}
  16 module CoreUnfold (
  17         Unfolding(..), UnfoldingGuidance(..), -- types
  18
  19         FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
  20         exprIsTrivial,
  21
  22         noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
  23
  24         smallEnoughToInline, couldBeSmallEnoughToInline,
  25         certainlySmallEnoughToInline, inlineUnconditionally, okToInline,
  26         okToUnfoldInHiFile,
  27
  28         calcUnfoldingGuidance
  29     ) where
  30
  31 #include "HsVersions.h"
  32
  33 import {-# SOURCE #-} MagicUFs  ( MagicUnfoldingFun, mkMagicUnfoldingFun )
  34
  35 import CmdLineOpts      ( opt_UnfoldingCreationThreshold,
  36                           opt_UnfoldingUseThreshold,
  37                           opt_UnfoldingConDiscount,
  38                           opt_UnfoldingKeenessFactor,
  39                           opt_UnfoldCasms
  40                         )
  41 import Constants        ( uNFOLDING_CHEAP_OP_COST,
  42                           uNFOLDING_DEAR_OP_COST,
  43                           uNFOLDING_NOREP_LIT_COST
  44                         )
  45 import BinderInfo       ( BinderInfo, isOneSameSCCFunOcc, isDeadOcc,
  46                           isInlinableOcc, isOneSafeFunOcc
  47                         )
  48 import CoreSyn
  49 import Literal          ( Literal )
  50 import CoreUtils        ( unTagBinders )
  51 import OccurAnal        ( occurAnalyseGlobalExpr )
  52 import CoreUtils        ( coreExprType )
  53 import Id               ( Id, idType, getIdArity,  isBottomingId, isDataCon,
  54                           idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
  55                           IdSet )
  56 import PrimOp           ( fragilePrimOp, primOpCanTriggerGC, PrimOp(..) )
  57 import IdInfo           ( ArityInfo(..), InlinePragInfo(..) )
  58 import Name             ( isExported )
  59 import Literal          ( isNoRepLit, isLitLitLit )
  60 import TyCon            ( tyConFamilySize )
  61 import Type             ( splitAlgTyConApp_maybe )
  62 import Unique           ( Unique )
  63 import Util             ( isIn, panic, assertPanic )
  64 import Outputable
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection{@Unfolding@ and @UnfoldingGuidance@ types}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74 data Unfolding
  75   = NoUnfolding
  76
  77   | OtherLit [Literal]          -- It ain't one of these
  78   | OtherCon [Id]               -- It ain't one of these
  79
  80   | CoreUnfolding                       -- An unfolding with redundant cached information
  81                 FormSummary             -- Tells whether the template is a WHNF or bottom
  82                 UnfoldingGuidance       -- Tells about the *size* of the template.
  83                 SimplifiableCoreExpr    -- Template
  84
  85   | MagicUnfolding
  86         Unique                          -- Unique of the Id whose magic unfolding this is
  87         MagicUnfoldingFun
  88 \end{code}
  89
  90 \begin{code}
  91 noUnfolding = NoUnfolding
  92
  93 mkUnfolding expr
  94   = let
  95      -- strictness mangling (depends on there being no CSE)
  96      ufg = calcUnfoldingGuidance opt_UnfoldingCreationThreshold expr
  97      occ = occurAnalyseGlobalExpr expr
  98      cuf = CoreUnfolding (mkFormSummary expr) ufg occ
  99
 100      cont = case occ of { Var _ -> cuf; _ -> cuf }
 101     in
 102     case ufg of { UnfoldAlways -> cont; _ -> cont }
 103
 104 mkMagicUnfolding :: Unique -> Unfolding
 105 mkMagicUnfolding tag  = MagicUnfolding tag (mkMagicUnfoldingFun tag)
 106
 107 getUnfoldingTemplate :: Unfolding -> CoreExpr
 108 getUnfoldingTemplate (CoreUnfolding _ _ expr)
 109   = unTagBinders expr
 110 getUnfoldingTemplate other = panic "getUnfoldingTemplate"
 111
 112
 113 data UnfoldingGuidance
 114   = UnfoldNever
 115   | UnfoldAlways                -- There is no "original" definition,
 116                                 -- so you'd better unfold.  Or: something
 117                                 -- so cheap to unfold (e.g., 1#) that
 118                                 -- you should do it absolutely always.
 119
 120   | UnfoldIfGoodArgs    Int     -- if "m" type args
 121                         Int     -- and "n" value args
 122
 123                         [Int]   -- Discount if the argument is evaluated.
 124                                 -- (i.e., a simplification will definitely
 125                                 -- be possible).  One elt of the list per *value* arg.
 126
 127                         Int     -- The "size" of the unfolding; to be elaborated
 128                                 -- later. ToDo
 129
 130                         Int     -- Scrutinee discount: the discount to substract if the thing is in
 131                                 -- a context (case (thing args) of ...),
 132                                 -- (where there are the right number of arguments.)
 133 \end{code}
 134
 135 \begin{code}
 136 instance Outputable UnfoldingGuidance where
 137     ppr UnfoldAlways            = ptext SLIT("_ALWAYS_")
 138     ppr (UnfoldIfGoodArgs t v cs size discount)
 139       = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
 140                if null cs       -- always print *something*
 141                 then char 'X'
 142                 else hcat (map (text . show) cs),
 143                int size,
 144                int discount ]
 145 \end{code}
 146
 147
 148 %************************************************************************
 149 %*                                                                      *
 150 \subsection{Figuring out things about expressions}
 151 %*                                                                      *
 152 %************************************************************************
 153
 154 \begin{code}
 155 data FormSummary
 156   = VarForm             -- Expression is a variable (or scc var, etc)
 157   | ValueForm           -- Expression is a value: i.e. a value-lambda,constructor, or literal
 158   | BottomForm          -- Expression is guaranteed to be bottom. We're more gung
 159                         -- ho about inlining such things, because it can't waste work
 160   | OtherForm           -- Anything else
 161
 162 instance Outputable FormSummary where
 163    ppr VarForm    = ptext SLIT("Var")
 164    ppr ValueForm  = ptext SLIT("Value")
 165    ppr BottomForm = ptext SLIT("Bot")
 166    ppr OtherForm  = ptext SLIT("Other")
 167
 168 mkFormSummary ::GenCoreExpr bndr Id flexi -> FormSummary
 169
 170 mkFormSummary expr
 171   = go (0::Int) expr            -- The "n" is the number of (value) arguments so far
 172   where
 173     go n (Lit _)        = ASSERT(n==0) ValueForm
 174     go n (Con _ _)      = ASSERT(n==0) ValueForm
 175     go n (Prim _ _)     = OtherForm
 176     go n (Note _ e)     = go n e
 177
 178     go n (Let (NonRec b r) e) | exprIsTrivial r = go n e        -- let f = f' alpha in (f,g)
 179                                                                 -- should be treated as a value
 180     go n (Let _ e)      = OtherForm
 181     go n (Case _ _)     = OtherForm
 182
 183     go 0 (Lam (ValBinder x) e) = ValueForm      -- NB: \x.bottom /= bottom!
 184     go n (Lam (ValBinder x) e) = go (n-1) e     -- Applied lambda
 185     go n (Lam other_binder e)  = go n e
 186
 187     go n (App fun arg) | isValArg arg = go (n+1) fun
 188     go n (App fun other_arg)          = go n fun
 189
 190     go n (Var f) | isBottomingId f = BottomForm
 191                  | isDataCon f     = ValueForm          -- Can happen inside imported unfoldings
 192     go 0 (Var f)                   = VarForm
 193     go n (Var f)                   = case getIdArity f of
 194                                           ArityExactly a | n < a -> ValueForm
 195                                           ArityAtLeast a | n < a -> ValueForm
 196                                           other                  -> OtherForm
 197
 198 whnfOrBottom :: FormSummary -> Bool
 199 whnfOrBottom VarForm    = True
 200 whnfOrBottom ValueForm  = True
 201 whnfOrBottom BottomForm = True
 202 whnfOrBottom OtherForm  = False
 203 \end{code}
 204
 205 @exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate;
 206 simple variables and constants, and type applications.
 207
 208 \begin{code}
 209 exprIsTrivial (Var v)           = True
 210 exprIsTrivial (Lit lit)         = not (isNoRepLit lit)
 211 exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
 212 exprIsTrivial (Note _ e)        = exprIsTrivial e
 213 exprIsTrivial other             = False
 214 \end{code}
 215
 216 \begin{code}
 217 exprSmallEnoughToDup (Con _ _)      = True      -- Could check # of args
 218 exprSmallEnoughToDup (Prim op _)    = not (fragilePrimOp op) -- Could check # of args
 219 exprSmallEnoughToDup (Lit lit)      = not (isNoRepLit lit)
 220 exprSmallEnoughToDup (Note _ e)     = exprSmallEnoughToDup e
 221 exprSmallEnoughToDup expr
 222   = case (collectArgs expr) of { (fun, _, vargs) ->
 223     case fun of
 224       Var v | length vargs <= 4 -> True
 225       _                         -> False
 226     }
 227
 228 \end{code}
 229
 230
 231 %************************************************************************
 232 %*                                                                      *
 233 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
 234 %*                                                                      *
 235 %************************************************************************
 236
 237 \begin{code}
 238 calcUnfoldingGuidance
 239         :: Int                  -- bomb out if size gets bigger than this
 240         -> CoreExpr             -- expression to look at
 241         -> UnfoldingGuidance
 242 calcUnfoldingGuidance bOMB_OUT_SIZE expr
 243   = case collectBinders expr of { (ty_binders, val_binders, body) ->
 244     case (sizeExpr bOMB_OUT_SIZE val_binders body) of
 245
 246       TooBig -> UnfoldNever
 247
 248       SizeIs size cased_args scrut_discount
 249         -> UnfoldIfGoodArgs
 250                         (length ty_binders)
 251                         (length val_binders)
 252                         (map discount_for val_binders)
 253                         (I# size)
 254                         (I# scrut_discount)
 255         where
 256             discount_for b
 257                  | is_data && b `is_elem` cased_args = tyConFamilySize tycon
 258                  | otherwise = 0
 259                  where
 260                    (is_data, tycon)
 261                      = case (splitAlgTyConApp_maybe (idType b)) of
 262                           Nothing       -> (False, panic "discount")
 263                           Just (tc,_,_) -> (True,  tc)
 264
 265             is_elem = isIn "calcUnfoldingGuidance" }
 266 \end{code}
 267
 268 \begin{code}
 269 sizeExpr :: Int             -- Bomb out if it gets bigger than this
 270          -> [Id]            -- Arguments; we're interested in which of these
 271                             -- get case'd
 272          -> CoreExpr
 273          -> ExprSize
 274
 275 sizeExpr (I# bOMB_OUT_SIZE) args expr
 276   = size_up expr
 277   where
 278     size_up (Var v)                    = sizeZero
 279     size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
 280                       | otherwise      = sizeZero
 281
 282     size_up (Note _ body)  = size_up body               -- Notes cost nothing
 283
 284     size_up (App fun arg)  = size_up fun `addSize` size_up_arg arg
 285                                 -- NB Zero cost for for type applications;
 286                                 -- others cost 1 or more
 287
 288     size_up (Con con args) = conSizeN (numValArgs args)
 289                              -- We don't count 1 for the constructor because we're
 290                              -- quite keen to get constructors into the open
 291
 292     size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
 293       where
 294         op_cost = if primOpCanTriggerGC op
 295                   then uNFOLDING_DEAR_OP_COST
 296                         -- these *tend* to be more expensive;
 297                         -- number chosen to avoid unfolding (HACK)
 298                   else uNFOLDING_CHEAP_OP_COST
 299
 300     size_up expr@(Lam _ _)
 301       = let
 302             (tyvars, args, body) = collectBinders expr
 303         in
 304         size_up body `addSizeN` length args
 305
 306     size_up (Let (NonRec binder rhs) body)
 307       = nukeScrutDiscount (size_up rhs)
 308                 `addSize`
 309         size_up body
 310                 `addSizeN`
 311         1       -- For the allocation
 312
 313     size_up (Let (Rec pairs) body)
 314       = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
 315                 `addSize`
 316         size_up body
 317                 `addSizeN`
 318         length pairs    -- For the allocation
 319
 320     size_up (Case scrut alts)
 321       = nukeScrutDiscount (size_up scrut)
 322                 `addSize`
 323         arg_discount scrut
 324                 `addSize`
 325         size_up_alts (coreExprType scrut) alts
 326             -- We charge for the "case" itself in "size_up_alts"
 327
 328     ------------
 329         -- In an application we charge  0 for type application
 330         --                              1 for most anything else
 331         --                              N for norep_lits
 332     size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
 333     size_up_arg (TyArg _)                     = sizeZero
 334     size_up_arg other                         = sizeOne
 335
 336     ------------
 337     size_up_alts scrut_ty (AlgAlts alts deflt)
 338       = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
 339         `addSizeN`
 340         alt_cost
 341       where
 342         size_alg_alt (con,args,rhs) = size_up rhs
 343             -- Don't charge for args, so that wrappers look cheap
 344
 345         -- NB: we charge N for an alg. "case", where N is
 346         -- the number of constructors in the thing being eval'd.
 347         -- (You'll eventually get a "discount" of N if you
 348         -- think the "case" is likely to go away.)
 349         -- It's important to charge for alternatives.  If you don't then you
 350         -- get size 1 for things like:
 351         --              case x of { A -> 1#; B -> 2#; ... lots }
 352
 353         alt_cost :: Int
 354         alt_cost
 355           = case (splitAlgTyConApp_maybe scrut_ty) of
 356               Nothing       -> 1
 357               Just (tc,_,_) -> tyConFamilySize tc
 358
 359     size_up_alts _ (PrimAlts alts deflt)
 360       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
 361             -- *no charge* for a primitive "case"!
 362       where
 363         size_prim_alt (lit,rhs) = size_up rhs
 364
 365     ------------
 366     size_up_deflt NoDefault                = sizeZero
 367     size_up_deflt (BindDefault binder rhs) = size_up rhs
 368
 369     ------------
 370         -- We want to record if we're case'ing an argument
 371     arg_discount (Var v) | v `is_elem` args = scrutArg v
 372     arg_discount other                      = sizeZero
 373
 374     is_elem :: Id -> [Id] -> Bool
 375     is_elem = isIn "size_up_scrut"
 376
 377     ------------
 378         -- These addSize things have to be here because
 379         -- I don't want to give them bOMB_OUT_SIZE as an argument
 380
 381     addSizeN TooBig          _ = TooBig
 382     addSizeN (SizeIs n xs d) (I# m)
 383       | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
 384       | otherwise                   = TooBig
 385       where
 386         n_tot = n +# m
 387
 388     addSize TooBig _ = TooBig
 389     addSize _ TooBig = TooBig
 390     addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
 391       | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
 392       | otherwise                         = TooBig
 393       where
 394         n_tot = n1 +# n2
 395         d_tot = d1 +# d2
 396         xys   = xs ++ ys
 397
 398
 399 \end{code}
 400
 401 Code for manipulating sizes
 402
 403 \begin{code}
 404
 405 data ExprSize = TooBig
 406               | SizeIs Int#     -- Size found
 407                        [Id]     -- Arguments cased herein
 408                        Int#     -- Size to subtract if result is scrutinised
 409                                 -- by a case expression
 410
 411 sizeZero        = SizeIs 0# [] 0#
 412 sizeOne         = SizeIs 1# [] 0#
 413 sizeN (I# n)    = SizeIs n  [] 0#
 414 conSizeN (I# n) = SizeIs n  [] n
 415 scrutArg v      = SizeIs 0# [v] 0#
 416
 417 nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
 418 nukeScrutDiscount TooBig          = TooBig
 419 \end{code}
 420
 421 %************************************************************************
 422 %*                                                                      *
 423 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
 424 %*                                                                      *
 425 %************************************************************************
 426
 427 We have very limited information about an unfolding expression: (1)~so
 428 many type arguments and so many value arguments expected---for our
 429 purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
 430 a single integer.  (3)~An ``argument info'' vector.  For this, what we
 431 have at the moment is a Boolean per argument position that says, ``I
 432 will look with great favour on an explicit constructor in this
 433 position.'' (4)~The ``discount'' to subtract if the expression
 434 is being scrutinised.
 435
 436 Assuming we have enough type- and value arguments (if not, we give up
 437 immediately), then we see if the ``discounted size'' is below some
 438 (semi-arbitrary) threshold.  It works like this: for every argument
 439 position where we're looking for a constructor AND WE HAVE ONE in our
 440 hands, we get a (again, semi-arbitrary) discount [proportion to the
 441 number of constructors in the type being scrutinized].
 442
 443 If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
 444 and the expression in question will evaluate to a constructor, we use
 445 the computed discount size *for the result only* rather than
 446 computing the argument discounts. Since we know the result of
 447 the expression is going to be taken apart, discounting its size
 448 is more accurate (see @sizeExpr@ above for how this discount size
 449 is computed).
 450
 451 \begin{code}
 452 smallEnoughToInline :: Id                       -- The function (trace msg only)
 453                     -> [Bool]                   -- Evaluated-ness of value arguments
 454                     -> Bool                     -- Result is scrutinised
 455                     -> UnfoldingGuidance
 456                     -> Bool                     -- True => unfold it
 457
 458 smallEnoughToInline _ _ _ UnfoldAlways = True
 459 smallEnoughToInline _ _ _ UnfoldNever  = False
 460 smallEnoughToInline id arg_is_evald_s result_is_scruted
 461               (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
 462   = if enough_args n_vals_wanted arg_is_evald_s &&
 463        size - discount <= opt_UnfoldingUseThreshold
 464     then
 465        -- pprTrace "small enough" (ppr id <+> int size <+> int discount)
 466        True
 467     else
 468        False
 469   where
 470
 471     enough_args n [] | n > 0 = False    -- A function with no value args => don't unfold
 472     enough_args _ _          = True     -- Otherwise it's ok to try
 473
 474         -- We multiple the raw discounts (args_discount and result_discount)
 475         -- ty opt_UnfoldingKeenessFactor because the former have to do with
 476         -- *size* whereas the discounts imply that there's some extra *efficiency*
 477         -- to be gained (e.g. beta reductions, case reductions) by inlining.
 478     discount :: Int
 479     discount = round (
 480                       opt_UnfoldingKeenessFactor *
 481                       fromInt (args_discount + result_discount)
 482                      )
 483
 484     args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
 485     result_discount | result_is_scruted = scrut_discount
 486                     | otherwise         = 0
 487
 488     arg_discount no_of_constrs is_evald
 489       | is_evald  = no_of_constrs * opt_UnfoldingConDiscount
 490       | otherwise = 0
 491 \end{code}
 492
 493 We use this one to avoid exporting inlinings that we ``couldn't possibly
 494 use'' on the other side.  Can be overridden w/ flaggery.
 495 Just the same as smallEnoughToInline, except that it has no actual arguments.
 496
 497 \begin{code}
 498 couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 499 couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
 500
 501 certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
 502 certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
 503 \end{code}
 504
 505 Predicates
 506 ~~~~~~~~~~
 507
 508 @inlineUnconditionally@ decides whether a let-bound thing can
 509 *definitely* be inlined at each of its call sites.  If so, then
 510 we can drop the binding right away.  But remember, you have to be
 511 certain that every use can be inlined.  So, notably, any ArgOccs
 512 rule this out.  Since ManyOcc doesn't record FunOcc/ArgOcc
 513
 514 \begin{code}
 515 inlineUnconditionally :: (Id,BinderInfo) -> Bool
 516
 517 inlineUnconditionally (id, occ_info)
 518   |  idMustNotBeINLINEd id
 519   || isExported id
 520   =  False
 521
 522   |  isOneSameSCCFunOcc occ_info
 523   && idWantsToBeINLINEd id = True
 524
 525   |  isOneSafeFunOcc occ_info
 526   =  True
 527
 528   |  otherwise
 529   = False
 530 \end{code}
 531
 532 okToInline is used at call sites, so it is a bit more generous
 533
 534 \begin{code}
 535 okToInline :: Id                -- The Id
 536            -> Bool              -- The thing is WHNF or bottom;
 537            -> Bool              -- It's small enough to duplicate the code
 538            -> BinderInfo
 539            -> Bool              -- True <=> inline it
 540
 541 okToInline id _ _ _             -- Check the Id first
 542   | idWantsToBeINLINEd id = True
 543   | idMustNotBeINLINEd id = False
 544
 545 okToInline id whnf small binder_info
 546 #ifdef DEBUG
 547   | isDeadOcc binder_info
 548   = pprTrace "okToInline: dead" (ppr id) False
 549   | otherwise
 550 #endif
 551   = isInlinableOcc whnf small binder_info
 552 \end{code}
 553
 554 @okToUnfoldInHifile@ is used when emitting unfolding info into an interface
 555 file to determine whether an unfolding candidate really should be unfolded.
 556 The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
 557 into interface files.
 558
 559 The reason for inlining expressions containing _casm_s into interface files
 560 is that these fragments of C are likely to mention functions/#defines that
 561 will be out-of-scope when inlined into another module. This is not an
 562 unfixable problem for the user (just need to -#include the approp. header
 563 file), but turning it off seems to the simplest thing to do.
 564
 565 \begin{code}
 566 okToUnfoldInHiFile :: CoreExpr -> Bool
 567 okToUnfoldInHiFile e = opt_UnfoldCasms || go e
 568  where
 569     -- Race over an expression looking for CCalls..
 570     go (Var _)   = True
 571     go (Lit lit) = not (isLitLitLit lit)
 572     go (Note _ body)  = go body
 573     go (App fun arg)  = go fun
 574     go (Con con args) = True
 575     go (Prim op args) = okToUnfoldPrimOp op
 576     go (Lam _ body) = go body
 577     go (Let (NonRec binder rhs) body) = go rhs && go body
 578     go (Let (Rec pairs) body) = and (map go (body:rhses))
 579       where
 580         rhses = [ rhs | (_, rhs) <- pairs ]
 581     go (Case scrut alts) = and (map go (scrut:rhses))
 582       where
 583         rhses = getAltRhs alts
 584
 585         getAltRhs (PrimAlts alts deflt) =
 586             let ls = map snd alts  in
 587             case deflt of
 588               NoDefault -> ls
 589               BindDefault _ rhs -> rhs:ls
 590         getAltRhs (AlgAlts alts deflt) =
 591             let ls = map (\ (_,_,r) -> r) alts  in
 592             case deflt of
 593               NoDefault -> ls
 594               BindDefault _ rhs -> rhs:ls
 595
 596     -- ok to unfold a PrimOp as long as it's not a _casm_
 597     okToUnfoldPrimOp (CCallOp _ is_casm _ _ _ _) = not is_casm
 598     okToUnfoldPrimOp _                           = True
 599
 600 \end{code}