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