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