ghc/compiler/simplCore/OccurAnal.lhs

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