ghc/compiler/simplCore/OccurAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[OccurAnal]{Occurrence analysis pass}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 The occurrence analyser re-typechecks a core expression, returning a new
  11 core expression with (hopefully) improved usage information.
  12
  13 \begin{code}
  14 module OccurAnal (
  15         occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
  16     ) where
  17
  18 #include "HsVersions.h"
  19
  20 import BinderInfo
  21 import CmdLineOpts      ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
  22 import CoreSyn
  23 import Digraph          ( stronglyConnCompR, SCC(..) )
  24 import Id               ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
  25                           idType, idUnique, Id,
  26                           emptyIdSet, unionIdSets, mkIdSet,
  27                           elementOfIdSet,
  28                           addOneToIdSet, IdSet,
  29                           nullIdEnv, unitIdEnv, combineIdEnvs,
  30                           delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
  31                           mapIdEnv, lookupIdEnv, IdEnv
  32                         )
  33 import Specialise       ( idSpecVars )
  34 import Name             ( isExported, isLocallyDefined )
  35 import Type             ( splitFunTy_maybe, splitForAllTys )
  36 import Maybes           ( maybeToBool )
  37 import PprCore
  38 import Unique           ( u2i )
  39 import UniqFM           ( keysUFM )
  40 import Util             ( zipWithEqual )
  41 import Outputable
  42 \end{code}
  43
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection[OccurAnal-types]{Data types}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 \begin{code}
  52 data OccEnv =
  53   OccEnv
  54     Bool        -- IgnoreINLINEPragma flag
  55                 -- False <=> OK to use INLINEPragma information
  56                 -- True  <=> ignore INLINEPragma information
  57
  58     (Id -> IdSet -> Bool)       -- Tells whether an Id occurrence is interesting,
  59                                 -- given the set of in-scope variables
  60
  61     IdSet       -- In-scope Ids
  62
  63
  64 addNewCands :: OccEnv -> [Id] -> OccEnv
  65 addNewCands (OccEnv ip ifun cands) ids
  66   = OccEnv ip ifun (cands `unionIdSets` mkIdSet ids)
  67
  68 addNewCand :: OccEnv -> Id -> OccEnv
  69 addNewCand (OccEnv ip ifun cands) id
  70   = OccEnv ip ifun (addOneToIdSet cands id)
  71
  72 isCandidate :: OccEnv -> Id -> Bool
  73 isCandidate (OccEnv _ ifun cands) id = ifun id cands
  74
  75 inlineMe :: OccEnv -> Id -> Bool
  76 inlineMe env id
  77   = {-  See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
  78         not ignore_inline_prag &&
  79     -}
  80     idWantsToBeINLINEd id
  81
  82
  83 type UsageDetails = IdEnv BinderInfo    -- A finite map from ids to their usage
  84
  85 combineUsageDetails, combineAltsUsageDetails
  86         :: UsageDetails -> UsageDetails -> UsageDetails
  87
  88 combineUsageDetails usage1 usage2
  89   = combineIdEnvs addBinderInfo usage1 usage2
  90
  91 combineAltsUsageDetails usage1 usage2
  92   = combineIdEnvs orBinderInfo usage1 usage2
  93
  94 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
  95 addOneOcc usage id info
  96   = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
  97         -- ToDo: make this more efficient
  98
  99 emptyDetails = (nullIdEnv :: UsageDetails)
 100
 101 unitDetails id info = (unitIdEnv id info :: UsageDetails)
 102
 103 tagBinders :: UsageDetails          -- Of scope
 104            -> [Id]                  -- Binders
 105            -> (UsageDetails,        -- Details with binders removed
 106               [(Id,BinderInfo)])    -- Tagged binders
 107
 108 tagBinders usage binders =
 109  let
 110   usage' = usage `delManyFromIdEnv` binders
 111   uss    = [ (binder, usage_of usage binder) | binder <- binders ]
 112  in
 113  if isNullIdEnv usage' then
 114     (usage', uss)
 115  else
 116     (usage', uss)
 117 {-
 118   = (usage `delManyFromIdEnv` binders,
 119      [ (binder, usage_of usage binder) | binder <- binders ]
 120     )
 121 -}
 122 tagBinder :: UsageDetails           -- Of scope
 123           -> Id                     -- Binders
 124           -> (UsageDetails,         -- Details with binders removed
 125               (Id,BinderInfo))      -- Tagged binders
 126
 127 tagBinder usage binder =
 128  let
 129    usage'  = usage `delOneFromIdEnv` binder
 130    us      = usage_of usage binder
 131    cont =
 132     if isNullIdEnv usage' then  -- Bogus test to force evaluation.
 133        (usage', (binder, us))
 134     else
 135        (usage', (binder, us))
 136  in
 137  if isDeadOcc us then           -- Ditto
 138         cont
 139  else
 140         cont
 141
 142
 143 usage_of usage binder
 144   | isExported binder
 145   = noBinderInfo        -- Visible-elsewhere things count as many
 146   | otherwise
 147   = case (lookupIdEnv usage binder) of
 148       Nothing   -> deadOccurrence
 149       Just info -> info
 150
 151 isNeeded env usage binder = not (isDeadOcc (usage_of usage binder))
 152 \end{code}
 153
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 \subsection[OccurAnal-main]{Counting occurrences: main function}
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 Here's the externally-callable interface:
 162
 163 \begin{code}
 164 occurAnalyseBinds
 165         :: [CoreBinding]                -- input
 166         -> (SimplifierSwitch -> Bool)
 167         -> [SimplifiableCoreBinding]    -- output
 168
 169 occurAnalyseBinds binds simplifier_sw_chkr
 170   | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
 171                                      (vcat (map ppr_bind binds'))
 172                                      binds'
 173   | otherwise             = binds'
 174   where
 175     (_, binds') = doo initial_env binds
 176
 177     initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma)
 178                          (\id in_scope -> isLocallyDefined id)  -- Anything local is interesting
 179                          emptyIdSet                             -- Not actually used
 180
 181     doo env [] = (emptyDetails, [])
 182     doo env (bind:binds)
 183       = (final_usage, new_binds ++ the_rest)
 184       where
 185         new_env                  = env `addNewCands` (bindersOf bind)
 186         (binds_usage, the_rest)  = doo new_env binds
 187         (final_usage, new_binds) = occAnalBind env bind binds_usage
 188
 189         -- This really ought to be done properly by PprCore, but
 190         -- it isn't.  pprCoreBinding only works on Id binders, and
 191         -- the general case is complicated by the fact that it has to work
 192         -- for interface files too.  Sigh
 193
 194 ppr_bind bind@(NonRec binder expr)
 195   = ppr bind
 196
 197 ppr_bind bind@(Rec binds)
 198   = vcat [ptext SLIT("Rec {"),
 199               nest 2 (ppr bind),
 200               ptext SLIT("end Rec }")]
 201 \end{code}
 202
 203 \begin{code}
 204 occurAnalyseExpr :: (Id -> Bool)        -- Tells if a variable is interesting
 205                  -> CoreExpr
 206                  -> (IdEnv BinderInfo,  -- Occ info for interesting free vars
 207                      SimplifiableCoreExpr)
 208
 209 occurAnalyseExpr interesting expr
 210   = occAnal initial_env expr
 211   where
 212     initial_env = OccEnv False {- Do not ignore INLINE Pragma -}
 213                          (\id locals -> interesting id || elementOfIdSet id locals)
 214                          emptyIdSet
 215
 216 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
 217 occurAnalyseGlobalExpr expr
 218   =     -- Top level expr, so no interesting free vars, and
 219         -- discard occurence info returned
 220     snd (occurAnalyseExpr (\_ -> False) expr)
 221 \end{code}
 222
 223 %************************************************************************
 224 %*                                                                      *
 225 \subsection[OccurAnal-main]{Counting occurrences: main function}
 226 %*                                                                      *
 227 %************************************************************************
 228
 229 Bindings
 230 ~~~~~~~~
 231
 232 \begin{code}
 233 type Node details = (details, Int, [Int])       -- The Ints are gotten from the Unique,
 234                                                 -- which is gotten from the Id.
 235 type Details1     = (Id, UsageDetails, SimplifiableCoreExpr)
 236 type Details2     = ((Id, BinderInfo), SimplifiableCoreExpr)
 237
 238
 239 occAnalBind :: OccEnv
 240             -> CoreBinding
 241             -> UsageDetails             -- Usage details of scope
 242             -> (UsageDetails,           -- Of the whole let(rec)
 243                 [SimplifiableCoreBinding])
 244
 245 occAnalBind env (NonRec binder rhs) body_usage
 246   | isNeeded env body_usage binder              -- It's mentioned in body
 247   = (final_body_usage `combineUsageDetails` rhs_usage,
 248      [NonRec tagged_binder rhs'])
 249
 250   | otherwise                   -- Not mentioned, so drop dead code
 251   = (body_usage, [])
 252
 253   where
 254     binder'                           = nukeNoInlinePragma binder
 255     (rhs_usage, rhs')                 = occAnalRhs env binder' rhs
 256     (final_body_usage, tagged_binder) = tagBinder body_usage binder'
 257 \end{code}
 258
 259 Dropping dead code for recursive bindings is done in a very simple way:
 260
 261         the entire set of bindings is dropped if none of its binders are
 262         mentioned in its body; otherwise none are.
 263
 264 This seems to miss an obvious improvement.
 265 @
 266         letrec  f = ...g...
 267                 g = ...f...
 268         in
 269         ...g...
 270
 271 ===>
 272
 273         letrec f = ...g...
 274                g = ...(...g...)...
 275         in
 276         ...g...
 277 @
 278
 279 Now @f@ is unused. But dependency analysis will sort this out into a
 280 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
 281 It isn't easy to do a perfect job in one blow.  Consider
 282
 283 @
 284         letrec f = ...g...
 285                g = ...h...
 286                h = ...k...
 287                k = ...m...
 288                m = ...m...
 289         in
 290         ...m...
 291 @
 292
 293
 294 \begin{code}
 295 occAnalBind env (Rec pairs) body_usage
 296   = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
 297   where
 298     pp_item (_, bndr, _)     = ppr bndr
 299
 300     binders = map fst pairs
 301     new_env = env `addNewCands` binders
 302
 303     analysed_pairs :: [Details1]
 304     analysed_pairs  = [ (nukeNoInlinePragma bndr, rhs_usage, rhs')
 305                       | (bndr, rhs) <- pairs,
 306                         let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs
 307                       ]
 308
 309     sccs :: [SCC (Node Details1)]
 310     sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
 311
 312
 313     ---- stuff for dependency analysis of binds -------------------------------
 314     edges :: [Node Details1]
 315     edges = _scc_ "occAnalBind.assoc"
 316             [ (details, IBOX(u2i (idUnique id)), edges_from rhs_usage)
 317             | details@(id, rhs_usage, rhs) <- analysed_pairs
 318             ]
 319
 320         -- (a -> b) means a mentions b
 321         -- Given the usage details (a UFM that gives occ info for each free var of
 322         -- the RHS) we can get the list of free vars -- or rather their Int keys --
 323         -- by just extracting the keys from the finite map.  Grimy, but fast.
 324         -- Previously we had this:
 325         --      [ bndr | bndr <- bndrs,
 326         --               maybeToBool (lookupIdEnv rhs_usage bndr)]
 327         -- which has n**2 cost, and this meant that edges_from alone
 328         -- consumed 10% of total runtime!
 329     edges_from :: UsageDetails -> [Int]
 330     edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
 331                            keysUFM rhs_usage
 332
 333     ---- stuff to "re-constitute" bindings from dependency-analysis info ------
 334
 335         -- Non-recursive SCC
 336     do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
 337       | isNeeded env body_usage bndr
 338       = (combined_usage, new_bind : binds_so_far)
 339       | otherwise
 340       = (body_usage, binds_so_far)                      -- Dead code
 341       where
 342         total_usage                   = combineUsageDetails body_usage rhs_usage
 343         (combined_usage, tagged_bndr) = tagBinder total_usage bndr
 344         new_bind                      = NonRec tagged_bndr rhs'
 345
 346         -- Recursive SCC
 347     do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
 348       | any (isNeeded env body_usage) bndrs
 349       = (combined_usage, final_bind:binds_so_far)
 350       | otherwise
 351       = (body_usage, binds_so_far)                      -- Dead code
 352       where
 353         details                          = [details   | (details, _, _) <- cycle]
 354         bndrs                            = [bndr      | (bndr, _, _)      <- details]
 355         rhs_usages                       = [rhs_usage | (_, rhs_usage, _) <- details]
 356         total_usage                      = foldr combineUsageDetails body_usage rhs_usages
 357         (combined_usage, tagged_binders) = tagBinders total_usage bndrs
 358         final_bind                       = Rec (reOrderRec env new_cycle)
 359
 360         new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle)
 361         mk_new_bind (bndr, occ_info) ((_, _, rhs'), key, keys) = (((bndr, occ_info), rhs'), key, keys)
 362 \end{code}
 363
 364 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
 365 strongly connected component (there's guaranteed to be a cycle).  It returns the
 366 same pairs, but
 367         a) in a better order,
 368         b) with some of the Ids having a IMustNotBeINLINEd pragma
 369
 370 The "no-inline" Ids are sufficient to break all cycles in the SCC.  This means
 371 that the simplifier can guarantee not to loop provided it never records an inlining
 372 for these no-inline guys.
 373
 374 Furthermore, the order of the binds is such that if we neglect dependencies
 375 on the no-inline Ids then the binds are topologically sorted.  This means
 376 that the simplifier will generally do a good job if it works from top bottom,
 377 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
 378
 379 Here's a case that bit me:
 380
 381         letrec
 382                 a = b
 383                 b = \x. BIG
 384         in
 385         ...a...a...a....
 386
 387 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
 388
 389 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
 390 Perhaps something cleverer would suffice.
 391
 392 You might think that you can prevent non-termination simply by making
 393 sure that we simplify a recursive binding's RHS in an environment that
 394 simply clones the recursive Id.  But no.  Consider
 395
 396                 letrec f = \x -> let z = f x' in ...
 397
 398                 in
 399                 let n = f y
 400                 in
 401                 case n of { ... }
 402
 403 We bind n to its *simplified* RHS, we then *re-simplify* it when
 404 we inline n.  Then we may well inline f; and then the same thing
 405 happens with z!
 406
 407 I don't think it's possible to prevent non-termination by environment
 408 manipulation in this way.  Apart from anything else, successive
 409 iterations of the simplifier may unroll recursive loops in cases like
 410 that above.  The idea of beaking every recursive loop with an
 411 IMustNotBeINLINEd pragma is much much better.
 412
 413
 414 \begin{code}
 415 reOrderRec
 416         :: OccEnv
 417         -> SCC (Node Details2)
 418         -> [Details2]
 419                         -- Sorted into a plausible order.  Enough of the Ids have
 420                         --      dontINLINE pragmas that there are no loops left.
 421
 422         -- Non-recursive case
 423 reOrderRec env (AcyclicSCC (bind, _, _)) = [bind]
 424
 425         -- Common case of simple self-recursion
 426 reOrderRec env (CyclicSCC [bind])
 427   = [((addNoInlinePragma bndr, occ_info), rhs)]
 428   where
 429     (((bndr, occ_info), rhs), _, _) = bind
 430
 431 reOrderRec env (CyclicSCC binds)
 432   =     -- Choose a loop breaker, mark it no-inline,
 433         -- do SCC analysis on the rest, and recursively sort them out
 434     concat (map (reOrderRec env) (stronglyConnCompR unchosen))
 435     ++
 436     [((addNoInlinePragma bndr, occ_info), rhs)]
 437
 438   where
 439     (chosen_pair, unchosen) = choose_loop_breaker binds
 440     ((bndr,occ_info), rhs)  = chosen_pair
 441
 442         -- Choosing the loop breaker; heursitic
 443     choose_loop_breaker (bind@(details, _, _) : rest)
 444         |  not (null rest) &&
 445            bad_choice details
 446         =  (chosen, bind : unchosen)    -- Don't pick it
 447         | otherwise                     -- Pick it
 448         = (details,rest)
 449         where
 450           (chosen, unchosen) = choose_loop_breaker rest
 451
 452     bad_choice ((bndr, occ_info), rhs)
 453         =    var_rhs rhs                -- Dont pick var RHS
 454           || inlineMe env bndr          -- Dont pick INLINE thing
 455           || isOneFunOcc occ_info       -- Dont pick single-occ thing
 456           || not_fun_ty (idType bndr)   -- Dont pick data-ty thing
 457
 458         -- isOneFunOcc looks for one textual occurrence, whether inside lambda or whatever.
 459         -- We stick to just FunOccs because if we're not going to be able
 460         -- to inline the thing on this round it might be better to pick
 461         -- this one as the loop breaker.  Real example (the Enum Ordering instance
 462         -- from PrelBase):
 463         --      rec     f = \ x -> case d of (p,q,r) -> p x
 464         --              g = \ x -> case d of (p,q,r) -> q x
 465         --              d = (v, f, g)
 466         --
 467         -- Here, f and g occur just once; but we can't inline them into d.
 468         -- On the other hand we *could* simplify those case expressions if
 469         -- we didn't stupidly choose d as the loop breaker.
 470
 471     not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty))
 472                   where
 473                     (_, rho_ty) = splitForAllTys ty
 474
 475         -- A variable RHS
 476     var_rhs (Var v)   = True
 477     var_rhs other_rhs = False
 478 \end{code}
 479
 480 @occAnalRhs@ deals with the question of bindings where the Id is marked
 481 by an INLINE pragma.  For these we record that anything which occurs
 482 in its RHS occurs many times.  This pessimistically assumes that ths
 483 inlined binder also occurs many times in its scope, but if it doesn't
 484 we'll catch it next time round.  At worst this costs an extra simplifier pass.
 485 ToDo: try using the occurrence info for the inline'd binder.
 486
 487 [March 97] We do the same for atomic RHSs.  Reason: see notes with reOrderRec.
 488
 489 [March 98] A new wrinkle is that if the binder has specialisations inside
 490 it then we count the specialised Ids as "extra rhs's".  That way
 491 the "parent" keeps the specialised "children" alive.  If the parent
 492 dies (because it isn't referenced any more), then the children will
 493 die too unless they are already referenced directly.
 494
 495 \begin{code}
 496 occAnalRhs :: OccEnv
 497            -> Id -> CoreExpr    -- Binder and rhs
 498            -> (UsageDetails, SimplifiableCoreExpr)
 499
 500 occAnalRhs env id (Var v)
 501   | isCandidate env v
 502   = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
 503
 504   | otherwise
 505   = (emptyDetails, Var v)
 506
 507 occAnalRhs env id rhs
 508   | inlineMe env id
 509   = (mapIdEnv markMany total_usage, rhs')
 510
 511   | otherwise
 512   = (total_usage, rhs')
 513
 514   where
 515     (rhs_usage, rhs') = occAnal env rhs
 516     total_usage = foldr add rhs_usage (idSpecVars id)
 517     add v u     = addOneOcc u v (argOccurrence 0)
 518 \end{code}
 519
 520 Expressions
 521 ~~~~~~~~~~~
 522 \begin{code}
 523 occAnal :: OccEnv
 524         -> CoreExpr
 525         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
 526             SimplifiableCoreExpr)
 527
 528 occAnal env (Var v)
 529   | isCandidate env v
 530   = (unitIdEnv v (funOccurrence 0), Var v)
 531
 532   | otherwise
 533   = (emptyDetails, Var v)
 534
 535 occAnal env (Lit lit)      = (emptyDetails, Lit lit)
 536 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
 537 \end{code}
 538
 539 We regard variables that occur as constructor arguments as "dangerousToDup":
 540
 541 \begin{verbatim}
 542 module A where
 543 f x = let y = expensive x in
 544       let z = (True,y) in
 545       (case z of {(p,q)->q}, case z of {(p,q)->q})
 546 \end{verbatim}
 547
 548 We feel free to duplicate the WHNF (True,y), but that means
 549 that y may be duplicated thereby.
 550
 551 If we aren't careful we duplicate the (expensive x) call!
 552 Constructors are rather like lambdas in this way.
 553
 554 \begin{code}
 555 occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
 556                               Con con args)
 557
 558 occAnal env (SCC cc body)
 559   = (mapIdEnv markInsideSCC usage, SCC cc body')
 560   where
 561     (usage, body') = occAnal env body
 562
 563 occAnal env (Coerce c ty body)
 564   = (usage, Coerce c ty body')
 565   where
 566     (usage, body') = occAnal env body
 567
 568 occAnal env (App fun arg)
 569   = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
 570   where
 571     (fun_usage, fun') = occAnal    env fun
 572     arg_usage         = occAnalArg env arg
 573
 574 -- For value lambdas we do a special hack.  Consider
 575 --      (\x. \y. ...x...)
 576 -- If we did nothing, x is used inside the \y, so would be marked
 577 -- as dangerous to dup.  But in the common case where the abstraction
 578 -- is applied to two arguments this is over-pessimistic.
 579 -- So instead we don't take account of the \y when dealing with x's usage;
 580 -- instead, the simplifier is careful when partially applying lambdas
 581
 582 occAnal env expr@(Lam (ValBinder binder) body)
 583   = (mapIdEnv markDangerousToDup final_usage,
 584      foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
 585   where
 586     (binders,body)                = collectValBinders expr
 587     (body_usage, body')           = occAnal (env `addNewCands` binders) body
 588     (final_usage, tagged_binders) = tagBinders body_usage binders
 589
 590 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 591 occAnal env (Lam (TyBinder tyvar) body)
 592   = case occAnal env body of { (body_usage, body') ->
 593      (mapIdEnv markDangerousToDup body_usage,
 594       Lam (TyBinder tyvar) body') }
 595 --  where
 596 --    (body_usage, body') = occAnal env body
 597
 598 occAnal env (Case scrut alts)
 599   = case occAnalAlts env alts of { (alts_usage, alts')   ->
 600      case occAnal env scrut   of { (scrut_usage, scrut') ->
 601        let
 602         det = scrut_usage `combineUsageDetails` alts_usage
 603        in
 604        if isNullIdEnv det then
 605           (det, Case scrut' alts')
 606        else
 607           (det, Case scrut' alts') }}
 608 {-
 609        (scrut_usage `combineUsageDetails` alts_usage,
 610         Case scrut' alts')
 611   where
 612     (scrut_usage, scrut') = occAnal env scrut
 613     (alts_usage, alts')   = occAnalAlts env alts
 614 -}
 615
 616 occAnal env (Let bind body)
 617   = case occAnal new_env body            of { (body_usage, body') ->
 618     case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
 619        (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
 620   where
 621     new_env                  = env `addNewCands` (bindersOf bind)
 622 --    (body_usage, body')      = occAnal new_env body
 623 --    (final_usage, new_binds) = occAnalBind env bind body_usage
 624 \end{code}
 625
 626 Case alternatives
 627 ~~~~~~~~~~~~~~~~~
 628 \begin{code}
 629 occAnalAlts env (AlgAlts alts deflt)
 630   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 631         -- Note: combine*Alts*UsageDetails...
 632      AlgAlts alts' deflt')
 633   where
 634     (alts_usage,  alts')  = unzip (map do_alt alts)
 635     (deflt_usage, deflt') = occAnalDeflt env deflt
 636
 637     do_alt (con, args, rhs)
 638       = (final_usage, (con, tagged_args, rhs'))
 639       where
 640         new_env            = env `addNewCands` args
 641         (rhs_usage, rhs')          = occAnal new_env rhs
 642         (final_usage, tagged_args) = tagBinders rhs_usage args
 643
 644 occAnalAlts env (PrimAlts alts deflt)
 645   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 646         -- Note: combine*Alts*UsageDetails...
 647      PrimAlts alts' deflt')
 648   where
 649     (alts_usage, alts')   = unzip (map do_alt alts)
 650     (deflt_usage, deflt') = occAnalDeflt env deflt
 651
 652     do_alt (lit, rhs)
 653       = (rhs_usage, (lit, rhs'))
 654       where
 655         (rhs_usage, rhs') = occAnal env rhs
 656
 657 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
 658
 659 occAnalDeflt env (BindDefault binder rhs)
 660   = (final_usage, BindDefault tagged_binder rhs')
 661   where
 662     new_env                      = env `addNewCand` binder
 663     (rhs_usage, rhs')            = occAnal new_env rhs
 664     (final_usage, tagged_binder) = tagBinder rhs_usage binder
 665 \end{code}
 666
 667
 668 Atoms
 669 ~~~~~
 670 \begin{code}
 671 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
 672
 673 occAnalArgs env atoms
 674   = foldr do_one_atom emptyDetails atoms
 675   where
 676     do_one_atom (VarArg v) usage
 677         | isCandidate env v = addOneOcc usage v (argOccurrence 0)
 678         | otherwise         = usage
 679     do_one_atom other_arg  usage = usage
 680
 681
 682 occAnalArg  :: OccEnv -> CoreArg -> UsageDetails
 683
 684 occAnalArg env (VarArg v)
 685   | isCandidate env v = unitDetails v (argOccurrence 0)
 686   | otherwise         = emptyDetails
 687 occAnalArg _   _      = emptyDetails
 688 \end{code}