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  if isDeadOcc us then           -- Ditto
 172         cont
 173  else
 174         cont
 175
 176
 177 usage_of usage binder
 178   | isExported binder = noBinderInfo    -- Visible-elsewhere things count as many
 179   | otherwise
 180   = case (lookupIdEnv usage binder) of
 181       Nothing   -> deadOccurrence
 182       Just info -> info
 183
 184 isNeeded env usage binder
 185   = if isDeadOcc (usage_of usage binder) then
 186         keepUnusedBinding env binder    -- Maybe keep it anyway
 187     else
 188         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
 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 You might think that you can prevent non-termination simply by making
 435 sure that we simplify a recursive binding's RHS in an environment that
 436 simply clones the recursive Id.  But no.  Consider
 437
 438                 letrec f = \x -> let z = f x' in ...
 439
 440                 in
 441                 let n = f y
 442                 in
 443                 case n of { ... }
 444
 445 We bind n to its *simplified* RHS, we then *re-simplify* it when
 446 we inline n.  Then we may well inline f; and then the same thing
 447 happens with z!
 448
 449 I don't think it's possible to prevent non-termination by environment
 450 manipulation in this way.  Apart from anything else, successive
 451 iterations of the simplifier may unroll recursive loops in cases like
 452 that above.  The idea of beaking every recursive loop with an
 453 IMustNotBeINLINEd pragma is much much better.
 454
 455
 456 \begin{code}
 457 reOrderRec
 458         :: OccEnv
 459         -> SCC (Node Details2)
 460         -> [Details2]
 461                         -- Sorted into a plausible order.  Enough of the Ids have
 462                         --      dontINLINE pragmas that there are no loops left.
 463
 464         -- Non-recursive case
 465 reOrderRec env (AcyclicSCC (pair, _, _)) = [pair]
 466
 467         -- Common case of simple self-recursion
 468 reOrderRec env (CyclicSCC [bind])
 469   = [((addNoInlinePragma bndr, occ_info), rhs)]
 470   where
 471     (((bndr,occ_info), rhs), _, _) = bind
 472
 473 reOrderRec env (CyclicSCC binds)
 474   =     -- Choose a loop breaker, mark it no-inline,
 475         -- do SCC analysis on the rest, and recursively sort them out
 476     concat (map (reOrderRec env) (stronglyConnCompR unchosen))
 477     ++
 478     [((addNoInlinePragma bndr, occ_info), rhs)]
 479
 480   where
 481     (chosen_pair, unchosen) = choose_loop_breaker binds
 482     ((bndr,occ_info), rhs)  = chosen_pair
 483
 484         -- Choosing the loop breaker; heursitic
 485     choose_loop_breaker (bind@(pair, _, _) : rest)
 486         |  not (null rest) &&
 487            bad_choice pair
 488         =  (chosen, bind : unchosen)    -- Don't pick it
 489         | otherwise                     -- Pick it
 490         = (pair,rest)
 491         where
 492           (chosen, unchosen) = choose_loop_breaker rest
 493
 494     bad_choice ((bndr, occ_info), rhs)
 495         =    var_rhs rhs                -- Dont pick var RHS
 496           || inlineMe env bndr          -- Dont pick INLINE thing
 497           || isOneFunOcc occ_info       -- Dont pick single-occ thing
 498           || not_fun_ty (idType bndr)   -- Dont pick data-ty thing
 499
 500         -- isOneFunOcc looks for one textual occurrence, whether inside lambda or whatever.
 501         -- We stick to just FunOccs because if we're not going to be able
 502         -- to inline the thing on this round it might be better to pick
 503         -- this one as the loop breaker.  Real example (the Enum Ordering instance
 504         -- from PrelBase):
 505         --      rec     f = \ x -> case d of (p,q,r) -> p x
 506         --              g = \ x -> case d of (p,q,r) -> q x
 507         --              d = (v, f, g)
 508         --
 509         -- Here, f and g occur just once; but we can't inline them into d.
 510         -- On the other hand we *could* simplify those case expressions if
 511         -- we didn't stupidly choose d as the loop breaker.
 512
 513     not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty))
 514                   where
 515                     (_, rho_ty) = splitForAllTy ty
 516
 517         -- A variable RHS
 518     var_rhs (Var v)   = True
 519     var_rhs other_rhs = False
 520 \end{code}
 521
 522 @occAnalRhs@ deals with the question of bindings where the Id is marked
 523 by an INLINE pragma.  For these we record that anything which occurs
 524 in its RHS occurs many times.  This pessimistically assumes that ths
 525 inlined binder also occurs many times in its scope, but if it doesn't
 526 we'll catch it next time round.  At worst this costs an extra simplifier pass.
 527 ToDo: try using the occurrence info for the inline'd binder.
 528
 529 [March 97] We do the same for atomic RHSs.  Reason: see notes with reOrderRec.
 530
 531 \begin{code}
 532 occAnalRhs :: OccEnv
 533            -> Id -> CoreExpr    -- Binder and rhs
 534            -> (UsageDetails, SimplifiableCoreExpr)
 535
 536 occAnalRhs env id (Var v)
 537   | isCandidate env v
 538   = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
 539
 540   | otherwise
 541   = (emptyDetails, Var v)
 542
 543 occAnalRhs env id rhs
 544   | inlineMe env id
 545   = (mapIdEnv markMany rhs_usage, rhs')
 546
 547   | otherwise
 548   = (rhs_usage, rhs')
 549
 550   where
 551     (rhs_usage, rhs') = occAnal env rhs
 552 \end{code}
 553
 554 Expressions
 555 ~~~~~~~~~~~
 556 \begin{code}
 557 occAnal :: OccEnv
 558         -> CoreExpr
 559         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
 560             SimplifiableCoreExpr)
 561
 562 occAnal env (Var v)
 563   | isCandidate env v
 564   = (unitIdEnv v (funOccurrence 0), Var v)
 565
 566   | otherwise
 567   = (emptyDetails, Var v)
 568
 569 occAnal env (Lit lit)      = (emptyDetails, Lit lit)
 570 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
 571 \end{code}
 572
 573 We regard variables that occur as constructor arguments as "dangerousToDup":
 574
 575 \begin{verbatim}
 576 module A where
 577 f x = let y = expensive x in
 578       let z = (True,y) in
 579       (case z of {(p,q)->q}, case z of {(p,q)->q})
 580 \end{verbatim}
 581
 582 We feel free to duplicate the WHNF (True,y), but that means
 583 that y may be duplicated thereby.
 584
 585 If we aren't careful we duplicate the (expensive x) call!
 586 Constructors are rather like lambdas in this way.
 587
 588 \begin{code}
 589 occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
 590                               Con con args)
 591
 592 occAnal env (SCC cc body)
 593   = (mapIdEnv markInsideSCC usage, SCC cc body')
 594   where
 595     (usage, body') = occAnal env body
 596
 597 occAnal env (Coerce c ty body)
 598   = (usage, Coerce c ty body')
 599   where
 600     (usage, body') = occAnal env body
 601
 602 occAnal env (App fun arg)
 603   = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
 604   where
 605     (fun_usage, fun') = occAnal    env fun
 606     arg_usage         = occAnalArg env arg
 607
 608 -- For value lambdas we do a special hack.  Consider
 609 --      (\x. \y. ...x...)
 610 -- If we did nothing, x is used inside the \y, so would be marked
 611 -- as dangerous to dup.  But in the common case where the abstraction
 612 -- is applied to two arguments this is over-pessimistic.
 613 -- So instead we don't take account of the \y when dealing with x's usage;
 614 -- instead, the simplifier is careful when partially applying lambdas
 615
 616 occAnal env expr@(Lam (ValBinder binder) body)
 617   = (mapIdEnv markDangerousToDup final_usage,
 618      foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
 619   where
 620     (binders,body)                = collectValBinders expr
 621     (body_usage, body')           = occAnal (env `addNewCands` binders) body
 622     (final_usage, tagged_binders) = tagBinders body_usage binders
 623
 624 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 625 occAnal env (Lam (TyBinder tyvar) body)
 626   = case occAnal env body of { (body_usage, body') ->
 627      (mapIdEnv markDangerousToDup body_usage,
 628       Lam (TyBinder tyvar) body') }
 629 --  where
 630 --    (body_usage, body') = occAnal env body
 631
 632 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
 633
 634 occAnal env (Case scrut alts)
 635   = case occAnalAlts env alts of { (alts_usage, alts')   ->
 636      case occAnal env scrut   of { (scrut_usage, scrut') ->
 637        let
 638         det = scrut_usage `combineUsageDetails` alts_usage
 639        in
 640        if isNullIdEnv det then
 641           (det, Case scrut' alts')
 642        else
 643           (det, Case scrut' alts') }}
 644 {-
 645        (scrut_usage `combineUsageDetails` alts_usage,
 646         Case scrut' alts')
 647   where
 648     (scrut_usage, scrut') = occAnal env scrut
 649     (alts_usage, alts')   = occAnalAlts env alts
 650 -}
 651
 652 occAnal env (Let bind body)
 653   = case occAnal new_env body            of { (body_usage, body') ->
 654     case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
 655        (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
 656   where
 657     new_env                  = env `addNewCands` (bindersOf bind)
 658 --    (body_usage, body')      = occAnal new_env body
 659 --    (final_usage, new_binds) = occAnalBind env bind body_usage
 660 \end{code}
 661
 662 Case alternatives
 663 ~~~~~~~~~~~~~~~~~
 664 \begin{code}
 665 occAnalAlts env (AlgAlts alts deflt)
 666   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 667         -- Note: combine*Alts*UsageDetails...
 668      AlgAlts alts' deflt')
 669   where
 670     (alts_usage,  alts')  = unzip (map do_alt alts)
 671     (deflt_usage, deflt') = occAnalDeflt env deflt
 672
 673     do_alt (con, args, rhs)
 674       = (final_usage, (con, tagged_args, rhs'))
 675       where
 676         new_env            = env `addNewCands` args
 677         (rhs_usage, rhs')          = occAnal new_env rhs
 678         (final_usage, tagged_args) = tagBinders rhs_usage args
 679
 680 occAnalAlts env (PrimAlts alts deflt)
 681   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 682         -- Note: combine*Alts*UsageDetails...
 683      PrimAlts alts' deflt')
 684   where
 685     (alts_usage, alts')   = unzip (map do_alt alts)
 686     (deflt_usage, deflt') = occAnalDeflt env deflt
 687
 688     do_alt (lit, rhs)
 689       = (rhs_usage, (lit, rhs'))
 690       where
 691         (rhs_usage, rhs') = occAnal env rhs
 692
 693 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
 694
 695 occAnalDeflt env (BindDefault binder rhs)
 696   = (final_usage, BindDefault tagged_binder rhs')
 697   where
 698     new_env                      = env `addNewCand` binder
 699     (rhs_usage, rhs')            = occAnal new_env rhs
 700     (final_usage, tagged_binder) = tagBinder rhs_usage binder
 701 \end{code}
 702
 703
 704 Atoms
 705 ~~~~~
 706 \begin{code}
 707 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
 708
 709 occAnalArgs env atoms
 710   = foldr do_one_atom emptyDetails atoms
 711   where
 712     do_one_atom (VarArg v) usage
 713         | isCandidate env v = addOneOcc usage v (argOccurrence 0)
 714         | otherwise         = usage
 715     do_one_atom other_arg  usage = usage
 716
 717
 718 occAnalArg  :: OccEnv -> CoreArg -> UsageDetails
 719
 720 occAnalArg env (VarArg v)
 721   | isCandidate env v = unitDetails v (argOccurrence 0)
 722   | otherwise         = emptyDetails
 723 occAnalArg _   _      = emptyDetails
 724 \end{code}