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