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