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