ghc/compiler/simplCore/OccurAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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         markBinderInsideLambda
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 import BinderInfo
  22 import CmdLineOpts      ( SimplifierSwitch(..) )
  23 import CoreSyn
  24 import CoreUtils        ( exprIsTrivial, idSpecVars )
  25 import Const            ( Con(..), Literal(..) )
  26 import Id               ( idWantsToBeINLINEd,
  27                           getInlinePragma, setInlinePragma,
  28                           omitIfaceSigForId,
  29                           getIdSpecialisation,
  30                           idType, idUnique, Id
  31                         )
  32 import IdInfo           ( InlinePragInfo(..), OccInfo(..) )
  33 import SpecEnv          ( isEmptySpecEnv )
  34
  35 import VarSet
  36 import VarEnv
  37
  38 import PrelInfo         ( noRepStrIds, noRepIntegerIds )
  39 import Name             ( isExported, isLocallyDefined )
  40 import Type             ( splitFunTy_maybe, splitForAllTys )
  41 import Maybes           ( maybeToBool )
  42 import Digraph          ( stronglyConnCompR, SCC(..) )
  43 import Unique           ( u2i )
  44 import UniqFM           ( keysUFM )
  45 import Util             ( zipWithEqual, mapAndUnzip )
  46 import Outputable
  47 \end{code}
  48
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection[OccurAnal-main]{Counting occurrences: main function}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 Here's the externally-callable interface:
  57
  58 \begin{code}
  59 occurAnalyseBinds
  60         :: (SimplifierSwitch -> Bool)
  61         -> [CoreBind]
  62         -> [CoreBind]
  63
  64 occurAnalyseBinds simplifier_sw_chkr binds
  65   = binds'
  66   where
  67     (_, _, binds') = occAnalTop initial_env binds
  68
  69     initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma)
  70                          (\id -> isLocallyDefined id)   -- Anything local is interesting
  71                          emptyVarSet
  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                      CoreExpr)
  80
  81 occurAnalyseExpr interesting expr
  82   = occAnal initial_env expr
  83   where
  84     initial_env = OccEnv False {- Do not ignore INLINE Pragma -}
  85                          interesting
  86                          emptyVarSet
  87
  88 occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
  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            -> [CoreBind]
 154            -> (IdEnv BinderInfo,        -- Occurrence info
 155                IdEnv Id,                -- Indirection elimination info
 156                [CoreBind]
 157               )
 158
 159 occAnalTop env [] = (emptyDetails, emptyVarEnv, [])
 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 (bind : binds)
 168   = case bind of
 169         NonRec exported_id (Var local_id) | shortMeOut ind_env exported_id local_id
 170                 ->      -- Aha!  An indirection; let's eliminate it!
 171                    (scope_usage, ind_env', binds')
 172                 where
 173                    ind_env' = extendVarEnv ind_env local_id exported_id
 174
 175         other   ->      -- Ho ho! The normal case
 176                    (final_usage, ind_env, new_binds ++ binds')
 177                 where
 178                    (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage
 179   where
 180     new_env                        = env `addNewCands` (bindersOf bind)
 181     (scope_usage, ind_env, binds') = occAnalTop new_env binds
 182
 183         -- Deal with any indirections
 184     zap_bind (NonRec bndr rhs)
 185         | bndr `elemVarEnv` ind_env                     = Rec (zap (bndr,rhs))
 186                 -- The Rec isn't strictly necessary, but it's convenient
 187     zap_bind (Rec pairs)
 188         | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs))
 189
 190     zap_bind bind = bind
 191
 192     zap pair@(bndr,rhs) = case lookupVarEnv ind_env bndr of
 193                             Nothing          -> [pair]
 194                             Just exported_id -> [(bndr, Var exported_id),
 195                                                  (exported_id, rhs)]
 196
 197 shortMeOut ind_env exported_id local_id
 198   = isExported exported_id &&           -- Only if this is exported
 199
 200     isLocallyDefined local_id &&        -- Only if this one is defined in this
 201                                         --      module, so that we *can* change its
 202                                         --      binding to be the exported thing!
 203
 204     not (isExported local_id) &&        -- Only if this one is not itself exported,
 205                                         --      since the transformation will nuke it
 206
 207     not (omitIfaceSigForId local_id) && -- Don't do the transformation if rhs_id is
 208                                         --      something like a constructor, whose
 209                                         --      definition is implicitly exported and
 210                                         --      which must not vanish.
 211                 -- To illustrate the preceding check consider
 212                 --      data T = MkT Int
 213                 --      mkT = MkT
 214                 --      f x = MkT (x+1)
 215                 -- Here, we'll make a local, non-exported, defn for MkT, and without the
 216                 -- above condition we'll transform it to:
 217                 --      mkT = \x. MkT [x]
 218                 --      f = \y. mkT (y+1)
 219                 -- This is bad because mkT will get the IdDetails of MkT, and won't
 220                 -- be exported.  Also the code generator won't make a definition for
 221                 -- the MkT constructor.
 222                 -- Slightly gruesome, this.
 223
 224
 225     not (local_id `elemVarEnv` ind_env)         -- Only if not already substituted for
 226 \end{code}
 227
 228
 229 %************************************************************************
 230 %*                                                                      *
 231 \subsection[OccurAnal-main]{Counting occurrences: main function}
 232 %*                                                                      *
 233 %************************************************************************
 234
 235 Bindings
 236 ~~~~~~~~
 237
 238 \begin{code}
 239 type IdWithOccInfo = Id                 -- An Id with fresh PragmaInfo attached
 240
 241 type Node details = (details, Int, [Int])       -- The Ints are gotten from the Unique,
 242                                                 -- which is gotten from the Id.
 243 type Details1     = (Id, UsageDetails, CoreExpr)
 244 type Details2     = (IdWithOccInfo, CoreExpr)
 245
 246
 247 occAnalBind :: OccEnv
 248             -> CoreBind
 249             -> UsageDetails             -- Usage details of scope
 250             -> (UsageDetails,           -- Of the whole let(rec)
 251                 [CoreBind])
 252
 253 occAnalBind env (NonRec binder rhs) body_usage
 254   | isDeadBinder tagged_binder          -- It's not mentioned
 255   = (body_usage, [])
 256
 257   | otherwise                   -- It's mentioned in the body
 258   = (final_body_usage `combineUsageDetails` rhs_usage,
 259      [NonRec tagged_binder rhs'])
 260
 261   where
 262     (final_body_usage, tagged_binder) = tagBinder body_usage binder
 263     (rhs_usage, rhs')                 = occAnalRhs env binder rhs
 264 \end{code}
 265
 266 Dropping dead code for recursive bindings is done in a very simple way:
 267
 268         the entire set of bindings is dropped if none of its binders are
 269         mentioned in its body; otherwise none are.
 270
 271 This seems to miss an obvious improvement.
 272 @
 273         letrec  f = ...g...
 274                 g = ...f...
 275         in
 276         ...g...
 277
 278 ===>
 279
 280         letrec f = ...g...
 281                g = ...(...g...)...
 282         in
 283         ...g...
 284 @
 285
 286 Now @f@ is unused. But dependency analysis will sort this out into a
 287 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
 288 It isn't easy to do a perfect job in one blow.  Consider
 289
 290 @
 291         letrec f = ...g...
 292                g = ...h...
 293                h = ...k...
 294                k = ...m...
 295                m = ...m...
 296         in
 297         ...m...
 298 @
 299
 300
 301 \begin{code}
 302 occAnalBind env (Rec pairs) body_usage
 303   = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
 304   where
 305     pp_item (_, bndr, _)     = ppr bndr
 306
 307     binders = map fst pairs
 308     new_env = env `addNewCands` binders
 309
 310     analysed_pairs :: [Details1]
 311     analysed_pairs  = [ (bndr, rhs_usage, rhs')
 312                       | (bndr, rhs) <- pairs,
 313                         let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs
 314                       ]
 315
 316     sccs :: [SCC (Node Details1)]
 317     sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
 318
 319
 320     ---- stuff for dependency analysis of binds -------------------------------
 321     edges :: [Node Details1]
 322     edges = _scc_ "occAnalBind.assoc"
 323             [ (details, IBOX(u2i (idUnique id)), edges_from rhs_usage)
 324             | details@(id, rhs_usage, rhs) <- analysed_pairs
 325             ]
 326
 327         -- (a -> b) means a mentions b
 328         -- Given the usage details (a UFM that gives occ info for each free var of
 329         -- the RHS) we can get the list of free vars -- or rather their Int keys --
 330         -- by just extracting the keys from the finite map.  Grimy, but fast.
 331         -- Previously we had this:
 332         --      [ bndr | bndr <- bndrs,
 333         --               maybeToBool (lookupVarEnv rhs_usage bndr)]
 334         -- which has n**2 cost, and this meant that edges_from alone
 335         -- consumed 10% of total runtime!
 336     edges_from :: UsageDetails -> [Int]
 337     edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
 338                            keysUFM rhs_usage
 339
 340     ---- stuff to "re-constitute" bindings from dependency-analysis info ------
 341
 342         -- Non-recursive SCC
 343     do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
 344       | isDeadBinder tagged_bndr
 345       = (body_usage, binds_so_far)                      -- Dead code
 346       | otherwise
 347       = (combined_usage, new_bind : binds_so_far)
 348       where
 349         total_usage                   = combineUsageDetails body_usage rhs_usage
 350         (combined_usage, tagged_bndr) = tagBinder total_usage bndr
 351         new_bind                      = NonRec tagged_bndr rhs'
 352
 353         -- Recursive SCC
 354     do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
 355       | all isDeadBinder tagged_bndrs
 356       = (body_usage, binds_so_far)                      -- Dead code
 357       | otherwise
 358       = (combined_usage, final_bind:binds_so_far)
 359       where
 360         details                        = [details   | (details, _, _) <- cycle]
 361         bndrs                          = [bndr      | (bndr, _, _)      <- details]
 362         rhs_usages                     = [rhs_usage | (_, rhs_usage, _) <- details]
 363         total_usage                    = foldr combineUsageDetails body_usage rhs_usages
 364         (combined_usage, tagged_bndrs) = tagBinders total_usage bndrs
 365         final_bind                     = Rec (reOrderRec env new_cycle)
 366
 367         new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_bndrs cycle)
 368         mk_new_bind tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys)
 369 \end{code}
 370
 371 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
 372 strongly connected component (there's guaranteed to be a cycle).  It returns the
 373 same pairs, but
 374         a) in a better order,
 375         b) with some of the Ids having a IMustNotBeINLINEd pragma
 376
 377 The "no-inline" Ids are sufficient to break all cycles in the SCC.  This means
 378 that the simplifier can guarantee not to loop provided it never records an inlining
 379 for these no-inline guys.
 380
 381 Furthermore, the order of the binds is such that if we neglect dependencies
 382 on the no-inline Ids then the binds are topologically sorted.  This means
 383 that the simplifier will generally do a good job if it works from top bottom,
 384 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
 385
 386 ==============
 387 [June 98: I don't understand the following paragraphs, and I've
 388           changed the a=b case again so that it isn't a special case any more.]
 389
 390 Here's a case that bit me:
 391
 392         letrec
 393                 a = b
 394                 b = \x. BIG
 395         in
 396         ...a...a...a....
 397
 398 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
 399
 400 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
 401 Perhaps something cleverer would suffice.
 402 ===============
 403
 404 You might think that you can prevent non-termination simply by making
 405 sure that we simplify a recursive binding's RHS in an environment that
 406 simply clones the recursive Id.  But no.  Consider
 407
 408                 letrec f = \x -> let z = f x' in ...
 409
 410                 in
 411                 let n = f y
 412                 in
 413                 case n of { ... }
 414
 415 We bind n to its *simplified* RHS, we then *re-simplify* it when
 416 we inline n.  Then we may well inline f; and then the same thing
 417 happens with z!
 418
 419 I don't think it's possible to prevent non-termination by environment
 420 manipulation in this way.  Apart from anything else, successive
 421 iterations of the simplifier may unroll recursive loops in cases like
 422 that above.  The idea of beaking every recursive loop with an
 423 IMustNotBeINLINEd pragma is much much better.
 424
 425
 426 \begin{code}
 427 reOrderRec
 428         :: OccEnv
 429         -> SCC (Node Details2)
 430         -> [Details2]
 431                         -- Sorted into a plausible order.  Enough of the Ids have
 432                         --      dontINLINE pragmas that there are no loops left.
 433
 434         -- Non-recursive case
 435 reOrderRec env (AcyclicSCC (bind, _, _)) = [bind]
 436
 437         -- Common case of simple self-recursion
 438 reOrderRec env (CyclicSCC [bind])
 439   = [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)]
 440   where
 441     ((tagged_bndr, rhs), _, _) = bind
 442
 443 reOrderRec env (CyclicSCC (bind : binds))
 444   =     -- Choose a loop breaker, mark it no-inline,
 445         -- do SCC analysis on the rest, and recursively sort them out
 446     concat (map (reOrderRec env) (stronglyConnCompR unchosen))
 447     ++
 448     [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)]
 449
 450   where
 451     (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
 452     (tagged_bndr, rhs)      = chosen_pair
 453
 454         -- This loop looks for the bind with the lowest score
 455         -- to pick as the loop  breaker.  The rest accumulate in
 456     choose_loop_breaker (details,_,_) loop_sc acc []
 457         = (details, acc)        -- Done
 458
 459     choose_loop_breaker loop_bind loop_sc acc (bind : binds)
 460         | sc < loop_sc  -- Lower score so pick this new one
 461         = choose_loop_breaker bind sc (loop_bind : acc) binds
 462
 463         | otherwise     -- No lower so don't pick it
 464         = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
 465         where
 466           sc = score bind
 467
 468     score :: Node Details2 -> Int       -- Higher score => less likely to be picked as loop breaker
 469     score ((bndr, rhs), _, _)
 470         | exprIsTrivial rhs &&
 471           not (isExported bndr)    = 3          -- Practically certain to be inlined
 472         | inlineCandidate bndr     = 3          -- Likely to be inlined
 473         | not_fun_ty (idType bndr) = 2          -- Data types help with cases
 474         | not (isEmptySpecEnv (getIdSpecialisation bndr)) = 1
 475                 -- Avoid things with a SpecEnv; we'd like
 476                 -- to take advantage of the SpecEnv in the subsequent bindings
 477         | otherwise = 0
 478
 479     inlineCandidate :: Id -> Bool
 480     inlineCandidate id
 481       = case getInlinePragma id of
 482             IWantToBeINLINEd        -> True
 483             IMustBeINLINEd          -> True
 484             ICanSafelyBeINLINEd _ _ -> True
 485             other                   -> False
 486
 487         -- Real example (the Enum Ordering instance from PrelBase):
 488         --      rec     f = \ x -> case d of (p,q,r) -> p x
 489         --              g = \ x -> case d of (p,q,r) -> q x
 490         --              d = (v, f, g)
 491         --
 492         -- Here, f and g occur just once; but we can't inline them into d.
 493         -- On the other hand we *could* simplify those case expressions if
 494         -- we didn't stupidly choose d as the loop breaker.
 495         -- But we won't because constructor args are marked "Many".
 496
 497     not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty))
 498                   where
 499                     (_, rho_ty) = splitForAllTys ty
 500 \end{code}
 501
 502 @occAnalRhs@ deals with the question of bindings where the Id is marked
 503 by an INLINE pragma.  For these we record that anything which occurs
 504 in its RHS occurs many times.  This pessimistically assumes that ths
 505 inlined binder also occurs many times in its scope, but if it doesn't
 506 we'll catch it next time round.  At worst this costs an extra simplifier pass.
 507 ToDo: try using the occurrence info for the inline'd binder.
 508
 509 [March 97] We do the same for atomic RHSs.  Reason: see notes with reOrderRec.
 510 [June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with reOrderRec.
 511
 512 [March 98] A new wrinkle is that if the binder has specialisations inside
 513 it then we count the specialised Ids as "extra rhs's".  That way
 514 the "parent" keeps the specialised "children" alive.  If the parent
 515 dies (because it isn't referenced any more), then the children will
 516 die too unless they are already referenced directly.
 517
 518 \begin{code}
 519 occAnalRhs :: OccEnv
 520            -> Id -> CoreExpr    -- Binder and rhs
 521            -> (UsageDetails, CoreExpr)
 522
 523 {-      DELETED SLPJ June 98: seems quite bogus to me
 524 occAnalRhs env id (Var v)
 525   | isCandidate env v
 526   = (unitVarEnv v (markMany (funOccurrence 0)), Var v)
 527
 528   | otherwise
 529   = (emptyDetails, Var v)
 530 -}
 531
 532 occAnalRhs env id rhs
 533   | idWantsToBeINLINEd id
 534   = (mapVarEnv markMany total_usage, rhs')
 535
 536   | otherwise
 537   = (total_usage, rhs')
 538
 539   where
 540     (rhs_usage, rhs') = occAnal env rhs
 541     lazy_rhs_usage    = mapVarEnv markLazy rhs_usage
 542     total_usage       = foldVarSet add lazy_rhs_usage spec_ids
 543     add v u           = addOneOcc u v noBinderInfo      -- Give a non-committal binder info
 544                                                         -- (i.e manyOcc) because many copies
 545                                                         -- of the specialised thing can appear
 546     spec_ids = idSpecVars id
 547 \end{code}
 548
 549 \end{code}
 550
 551 Expressions
 552 ~~~~~~~~~~~
 553 \begin{code}
 554 occAnal :: OccEnv
 555         -> CoreExpr
 556         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
 557             CoreExpr)
 558
 559 occAnal env (Type t)  = (emptyDetails, Type t)
 560
 561 occAnal env (Var v)
 562   | isCandidate env v = (unitVarEnv v funOccZero, Var v)
 563   | otherwise         = (emptyDetails, Var v)
 564 \end{code}
 565
 566 We regard variables that occur as constructor arguments as "dangerousToDup":
 567
 568 \begin{verbatim}
 569 module A where
 570 f x = let y = expensive x in
 571       let z = (True,y) in
 572       (case z of {(p,q)->q}, case z of {(p,q)->q})
 573 \end{verbatim}
 574
 575 We feel free to duplicate the WHNF (True,y), but that means
 576 that y may be duplicated thereby.
 577
 578 If we aren't careful we duplicate the (expensive x) call!
 579 Constructors are rather like lambdas in this way.
 580
 581 \begin{code}
 582         -- For NoRep literals we have to report an occurrence of
 583         -- the things which tidyCore will later add, so that when
 584         -- we are compiling the very module in which those thin-air Ids
 585         -- are defined we have them in scope!
 586 occAnal env expr@(Con (Literal lit) args)
 587   = ASSERT( null args )
 588     (mk_lit_uds lit, expr)
 589   where
 590     mk_lit_uds (NoRepStr _ _)     = try noRepStrIds
 591     mk_lit_uds (NoRepInteger _ _) = try noRepIntegerIds
 592     mk_lit_uds lit                = emptyDetails
 593
 594     try vs = foldr add emptyDetails vs
 595     add v uds | isCandidate env v = extendVarEnv uds v funOccZero
 596               | otherwise         = uds
 597
 598 occAnal env (Con con args)
 599   = case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') ->
 600     let
 601         arg_uds          = foldr combineUsageDetails emptyDetails arg_uds_s
 602
 603         -- We mark the free vars of the argument of a constructor as "many"
 604         -- This means that nothing gets inlined into a constructor argument
 605         -- position, which is what we want.  Typically those constructor
 606         -- arguments are just variables, or trivial expressions.
 607         final_arg_uds    = case con of
 608                                 DataCon _ -> mapVarEnv markMany arg_uds
 609                                 other     -> arg_uds
 610     in
 611     (final_arg_uds, Con con args')
 612     }
 613 \end{code}
 614
 615 \begin{code}
 616 occAnal env (Note note@(SCC cc) body)
 617   = case occAnal env body of { (usage, body') ->
 618     (mapVarEnv markInsideSCC usage, Note note body')
 619     }
 620
 621 occAnal env (Note note body)
 622   = case occAnal env body of { (usage, body') ->
 623     (usage, Note note body')
 624     }
 625 \end{code}
 626
 627 \begin{code}
 628 occAnal env (App fun arg)
 629   = case occAnal env fun of { (fun_usage, fun') ->
 630     case occAnal env arg of { (arg_usage, arg') ->
 631     (fun_usage `combineUsageDetails` mapVarEnv markLazy arg_usage, App fun' arg')
 632     }}
 633
 634
 635 -- For value lambdas we do a special hack.  Consider
 636 --      (\x. \y. ...x...)
 637 -- If we did nothing, x is used inside the \y, so would be marked
 638 -- as dangerous to dup.  But in the common case where the abstraction
 639 -- is applied to two arguments this is over-pessimistic.
 640 -- So instead, we just mark each binder with its occurrence
 641 -- info in the *body* of the multiple lambda.
 642 -- Then, the simplifier is careful when partially applying lambdas.
 643
 644 occAnal env expr@(Lam _ _)
 645   = case occAnal (env `addNewCands` binders) body of { (body_usage, body') ->
 646     let
 647         (final_usage, tagged_binders) = tagBinders body_usage binders
 648     in
 649     (mapVarEnv markInsideLam final_usage,
 650      mkLams tagged_binders body') }
 651   where
 652     (binders, body) = collectBinders expr
 653
 654
 655 occAnal env (Case scrut bndr alts)
 656   = case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts')   ->
 657     case occAnal env scrut                     of { (scrut_usage, scrut') ->
 658     let
 659         alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
 660         (alts_usage1, tagged_bndr) = tagBinder alts_usage bndr
 661         total_usage = scrut_usage `combineUsageDetails` alts_usage1
 662     in
 663     total_usage `seq` (total_usage, Case scrut' tagged_bndr alts') }}
 664   where
 665     alt_env = env `addNewCand` bndr
 666
 667 occAnal env (Let bind body)
 668   = case occAnal new_env body            of { (body_usage, body') ->
 669     case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
 670        (final_usage, mkLets new_binds body') }}
 671   where
 672     new_env = env `addNewCands` (bindersOf bind)
 673 \end{code}
 674
 675 Case alternatives
 676 ~~~~~~~~~~~~~~~~~
 677 \begin{code}
 678 occAnalAlt env (con, bndrs, rhs)
 679   = case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') ->
 680     let
 681         (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
 682     in
 683     (final_usage, (con, tagged_bndrs, rhs')) }
 684 \end{code}
 685
 686
 687 %************************************************************************
 688 %*                                                                      *
 689 \subsection[OccurAnal-types]{Data types}
 690 %*                                                                      *
 691 %************************************************************************
 692
 693 \begin{code}
 694 data OccEnv =
 695   OccEnv
 696     Bool        -- IgnoreINLINEPragma flag
 697                 -- False <=> OK to use INLINEPragma information
 698                 -- True  <=> ignore INLINEPragma information
 699
 700     (Id -> Bool)        -- Tells whether an Id occurrence is interesting,
 701                         -- given the set of in-scope variables
 702
 703     IdSet       -- In-scope Ids
 704
 705
 706 addNewCands :: OccEnv -> [Id] -> OccEnv
 707 addNewCands (OccEnv ip ifun cands) ids
 708   = OccEnv ip ifun (cands `unionVarSet` mkVarSet ids)
 709
 710 addNewCand :: OccEnv -> Id -> OccEnv
 711 addNewCand (OccEnv ip ifun cands) id
 712   = OccEnv ip ifun (extendVarSet cands id)
 713
 714 isCandidate :: OccEnv -> Id -> Bool
 715 isCandidate (OccEnv _ ifun cands) id = id `elemVarSet` cands || ifun id
 716
 717
 718 type UsageDetails = IdEnv BinderInfo    -- A finite map from ids to their usage
 719
 720 combineUsageDetails, combineAltsUsageDetails
 721         :: UsageDetails -> UsageDetails -> UsageDetails
 722
 723 combineUsageDetails usage1 usage2
 724   = plusVarEnv_C addBinderInfo usage1 usage2
 725
 726 combineAltsUsageDetails usage1 usage2
 727   = plusVarEnv_C orBinderInfo usage1 usage2
 728
 729 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
 730 addOneOcc usage id info
 731   = plusVarEnv_C addBinderInfo usage (unitVarEnv id info)
 732         -- ToDo: make this more efficient
 733
 734 emptyDetails = (emptyVarEnv :: UsageDetails)
 735
 736 unitDetails id info = (unitVarEnv id info :: UsageDetails)
 737
 738 tagBinders :: UsageDetails          -- Of scope
 739            -> [Id]                  -- Binders
 740            -> (UsageDetails,        -- Details with binders removed
 741               [IdWithOccInfo])    -- Tagged binders
 742
 743 tagBinders usage binders
 744  = let
 745      usage' = usage `delVarEnvList` binders
 746      uss    = map (setBinderPrag usage) binders
 747    in
 748    usage' `seq` (usage', uss)
 749
 750 tagBinder :: UsageDetails           -- Of scope
 751           -> Id                     -- Binders
 752           -> (UsageDetails,         -- Details with binders removed
 753               IdWithOccInfo)        -- Tagged binders
 754
 755 tagBinder usage binder
 756  = let
 757      usage'  = usage `delVarEnv` binder
 758      binder' = setBinderPrag usage binder
 759    in
 760    usage' `seq` (usage', binder')
 761
 762
 763 setBinderPrag :: UsageDetails -> CoreBndr -> CoreBndr
 764 setBinderPrag usage bndr
 765   | isTyVar bndr
 766   = bndr
 767
 768   | otherwise
 769   = case old_prag of
 770         NoInlinePragInfo        -> new_bndr
 771         IAmDead                 -> new_bndr     -- The next three are annotations
 772         ICanSafelyBeINLINEd _ _ -> new_bndr     -- from the previous iteration of
 773         IAmALoopBreaker         -> new_bndr     -- the occurrence analyser
 774
 775         IAmASpecPragmaId        -> bndr         -- Don't ever overwrite or drop these as dead
 776
 777         other | its_now_dead    -> new_bndr     -- Overwrite the others iff it's now dead
 778               | otherwise       -> bndr
 779
 780   where
 781     old_prag = getInlinePragma bndr
 782     new_bndr = setInlinePragma bndr new_prag
 783
 784     its_now_dead = case new_prag of
 785                         IAmDead -> True
 786                         other   -> False
 787
 788     new_prag = occInfoToInlinePrag occ_info
 789
 790     occ_info
 791         | isExported bndr = noBinderInfo
 792         -- Don't use local usage info for visible-elsewhere things
 793         -- But NB that we do set NoInlinePragma for exported things
 794         -- thereby nuking any IAmALoopBreaker from a previous pass.
 795
 796         | otherwise       = case lookupVarEnv usage bndr of
 797                                     Nothing   -> deadOccurrence
 798                                     Just info -> info
 799
 800 markBinderInsideLambda :: CoreBndr -> CoreBndr
 801 markBinderInsideLambda bndr
 802   | isTyVar bndr
 803   = bndr
 804
 805   | otherwise
 806   = case getInlinePragma bndr of
 807         ICanSafelyBeINLINEd not_in_lam nalts
 808                 -> bndr `setInlinePragma` ICanSafelyBeINLINEd InsideLam nalts
 809         other   -> bndr
 810
 811 funOccZero = funOccurrence 0
 812 \end{code}