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