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