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, tagBinders,
  17         UsageDetails
  18     ) where
  19
  20 #include "HsVersions.h"
  21
  22 import BinderInfo
  23 import CmdLineOpts      ( SimplifierSwitch(..) )
  24 import CoreSyn
  25 import CoreFVs          ( idRuleVars )
  26 import CoreUtils        ( exprIsTrivial )
  27 import Literal          ( Literal(..) )
  28 import Id               ( isSpecPragmaId, isDataConId, isOneShotLambda, setOneShotLambda,
  29                           idOccInfo, setIdOccInfo,
  30                           isExportedId, modifyIdInfo, idInfo,
  31                           idSpecialisation,
  32                           idType, idUnique, Id
  33                         )
  34 import IdInfo           ( OccInfo(..), insideLam, copyIdInfo )
  35
  36 import VarSet
  37 import VarEnv
  38
  39 import Name             ( isLocallyDefined )
  40 import Type             ( splitFunTy_maybe, splitForAllTys )
  41 import Maybes           ( maybeToBool )
  42 import Digraph          ( stronglyConnCompR, SCC(..) )
  43 import Unique           ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
  44 import UniqFM           ( keysUFM )
  45 import Util             ( zipWithEqual, mapAndUnzip, count )
  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 occurAnalyseExpr :: (Id -> Bool)        -- Tells if a variable is interesting
  60                  -> CoreExpr
  61                  -> (IdEnv BinderInfo,  -- Occ info for interesting free vars
  62                      CoreExpr)
  63
  64 occurAnalyseExpr interesting expr
  65   = occAnal initial_env expr
  66   where
  67     initial_env = OccEnv interesting emptyVarSet []
  68
  69 occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
  70 occurAnalyseGlobalExpr expr
  71   =     -- Top level expr, so no interesting free vars, and
  72         -- discard occurence info returned
  73     snd (occurAnalyseExpr (\_ -> False) expr)
  74 \end{code}
  75
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection{Top level stuff}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 In @occAnalTop@ we do indirection-shorting.  That is, if we have this:
  84
  85         loc = <expression>
  86         ...
  87         exp = loc
  88
  89 where exp is exported, and loc is not, then we replace it with this:
  90
  91         loc = exp
  92         exp = <expression>
  93         ...
  94
  95 Without this we never get rid of the exp = loc thing.
  96 This save a gratuitous jump
  97 (from \tr{x_exported} to \tr{x_local}), and makes strictness
  98 information propagate better.
  99 This used to happen in the final phase, but it's tidier to do it here.
 100
 101
 102 If more than one exported thing is equal to a local thing (i.e., the
 103 local thing really is shared), then we do one only:
 104 \begin{verbatim}
 105         x_local = ....
 106         x_exported1 = x_local
 107         x_exported2 = x_local
 108 ==>
 109         x_exported1 = ....
 110
 111         x_exported2 = x_exported1
 112 \end{verbatim}
 113
 114 We rely on prior eta reduction to simplify things like
 115 \begin{verbatim}
 116         x_exported = /\ tyvars -> x_local tyvars
 117 ==>
 118         x_exported = x_local
 119 \end{verbatim}
 120 Hence,there's a possibility of leaving unchanged something like this:
 121 \begin{verbatim}
 122         x_local = ....
 123         x_exported1 = x_local Int
 124 \end{verbatim}
 125 By the time we've thrown away the types in STG land this
 126 could be eliminated.  But I don't think it's very common
 127 and it's dangerous to do this fiddling in STG land
 128 because we might elminate a binding that's mentioned in the
 129 unfolding for something.
 130
 131 \begin{code}
 132 occurAnalyseBinds :: [CoreBind] -> [CoreBind]
 133
 134 occurAnalyseBinds binds
 135   = binds'
 136   where
 137     (_, _, binds') = go initialTopEnv binds
 138
 139     go :: OccEnv -> [CoreBind]
 140        -> (UsageDetails,        -- Occurrence info
 141            IdEnv Id,            -- Indirection elimination info
 142            [CoreBind])
 143
 144     go env [] = (emptyDetails, emptyVarEnv, [])
 145
 146     go env (bind : binds)
 147       = let
 148             new_env                        = env `addNewCands` (bindersOf bind)
 149             (scope_usage, ind_env, binds') = go new_env binds
 150             (final_usage, new_binds)       = occAnalBind env (zapBind ind_env bind) scope_usage
 151                                                 -- NB: I zap before occur-analysing, so
 152                                                 -- I don't need to worry about getting the
 153                                                 -- occ info on the new bindings right.
 154         in
 155         case bind of
 156             NonRec exported_id (Var local_id)
 157                 | shortMeOut ind_env exported_id local_id
 158                 -- Special case for eliminating indirections
 159                 --   Note: it's a shortcoming that this only works for
 160                 --         non-recursive bindings.  Elminating indirections
 161                 --         makes perfect sense for recursive bindings too, but
 162                 --         it's more complicated to implement, so I haven't done so
 163                 -> (scope_usage, ind_env', binds')
 164                 where
 165                    ind_env' = extendVarEnv ind_env local_id exported_id
 166
 167             other ->    -- Ho ho! The normal case
 168                    (final_usage, ind_env, new_binds ++ binds')
 169
 170 initialTopEnv = OccEnv isLocallyDefined -- Anything local is interesting
 171                        emptyVarSet
 172                        []
 173
 174
 175 -- Deal with any indirections
 176 zapBind ind_env (NonRec bndr rhs)
 177   | bndr `elemVarEnv` ind_env                      = Rec (zap ind_env (bndr,rhs))
 178                 -- The Rec isn't strictly necessary, but it's convenient
 179 zapBind ind_env (Rec pairs)
 180   | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map (zap ind_env) pairs))
 181
 182 zapBind ind_env bind = bind
 183
 184 zap ind_env pair@(bndr,rhs)
 185   = case lookupVarEnv ind_env bndr of
 186         Nothing          -> [pair]
 187         Just exported_id -> [(bndr, Var exported_id),
 188                              (exported_id_w_info, rhs)]
 189                          where
 190                            exported_id_w_info = modifyIdInfo (copyIdInfo (idInfo bndr)) exported_id
 191                                 -- See notes with copyIdInfo about propagating IdInfo from
 192                                 -- one to t'other
 193
 194 shortMeOut ind_env exported_id local_id
 195   = isExportedId exported_id &&         -- Only if this is exported
 196
 197     isLocallyDefined local_id &&        -- Only if this one is defined in this
 198                                         --      module, so that we *can* change its
 199                                         --      binding to be the exported thing!
 200
 201     not (isExportedId local_id) &&      -- Only if this one is not itself exported,
 202                                         --      since the transformation will nuke it
 203
 204     not (local_id `elemVarEnv` ind_env)         -- Only if not already substituted for
 205 \end{code}
 206
 207
 208 %************************************************************************
 209 %*                                                                      *
 210 \subsection[OccurAnal-main]{Counting occurrences: main function}
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 Bindings
 215 ~~~~~~~~
 216
 217 \begin{code}
 218 type IdWithOccInfo = Id                 -- An Id with fresh PragmaInfo attached
 219
 220 type Node details = (details, Int, [Int])       -- The Ints are gotten from the Unique,
 221                                                 -- which is gotten from the Id.
 222 type Details1     = (Id, UsageDetails, CoreExpr)
 223 type Details2     = (IdWithOccInfo, CoreExpr)
 224
 225
 226 occAnalBind :: OccEnv
 227             -> CoreBind
 228             -> UsageDetails             -- Usage details of scope
 229             -> (UsageDetails,           -- Of the whole let(rec)
 230                 [CoreBind])
 231
 232 occAnalBind env (NonRec binder rhs) body_usage
 233   | not (binder `usedIn` body_usage)            -- It's not mentioned
 234   = (body_usage, [])
 235
 236   | otherwise                   -- It's mentioned in the body
 237   = (final_body_usage `combineUsageDetails` rhs_usage,
 238      [NonRec tagged_binder rhs'])
 239
 240   where
 241     (final_body_usage, tagged_binder) = tagBinder body_usage binder
 242     (rhs_usage, rhs')                 = occAnalRhs env binder rhs
 243 \end{code}
 244
 245 Dropping dead code for recursive bindings is done in a very simple way:
 246
 247         the entire set of bindings is dropped if none of its binders are
 248         mentioned in its body; otherwise none are.
 249
 250 This seems to miss an obvious improvement.
 251 @
 252         letrec  f = ...g...
 253                 g = ...f...
 254         in
 255         ...g...
 256
 257 ===>
 258
 259         letrec f = ...g...
 260                g = ...(...g...)...
 261         in
 262         ...g...
 263 @
 264
 265 Now @f@ is unused. But dependency analysis will sort this out into a
 266 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
 267 It isn't easy to do a perfect job in one blow.  Consider
 268
 269 @
 270         letrec f = ...g...
 271                g = ...h...
 272                h = ...k...
 273                k = ...m...
 274                m = ...m...
 275         in
 276         ...m...
 277 @
 278
 279
 280 \begin{code}
 281 occAnalBind env (Rec pairs) body_usage
 282   = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
 283   where
 284     pp_item (_, bndr, _)     = ppr bndr
 285
 286     binders = map fst pairs
 287     rhs_env = env `addNewCands` binders
 288
 289     analysed_pairs :: [Details1]
 290     analysed_pairs  = [ (bndr, rhs_usage, rhs')
 291                       | (bndr, rhs) <- pairs,
 292                         let (rhs_usage, rhs') = occAnalRhs rhs_env bndr rhs
 293                       ]
 294
 295     sccs :: [SCC (Node Details1)]
 296     sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
 297
 298
 299     ---- stuff for dependency analysis of binds -------------------------------
 300     edges :: [Node Details1]
 301     edges = _scc_ "occAnalBind.assoc"
 302             [ (details, IBOX(u2i (idUnique id)), edges_from rhs_usage)
 303             | details@(id, rhs_usage, rhs) <- analysed_pairs
 304             ]
 305
 306         -- (a -> b) means a mentions b
 307         -- Given the usage details (a UFM that gives occ info for each free var of
 308         -- the RHS) we can get the list of free vars -- or rather their Int keys --
 309         -- by just extracting the keys from the finite map.  Grimy, but fast.
 310         -- Previously we had this:
 311         --      [ bndr | bndr <- bndrs,
 312         --               maybeToBool (lookupVarEnv rhs_usage bndr)]
 313         -- which has n**2 cost, and this meant that edges_from alone
 314         -- consumed 10% of total runtime!
 315     edges_from :: UsageDetails -> [Int]
 316     edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
 317                            keysUFM rhs_usage
 318
 319     ---- stuff to "re-constitute" bindings from dependency-analysis info ------
 320
 321         -- Non-recursive SCC
 322     do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
 323       | not (bndr `usedIn` body_usage)
 324       = (body_usage, binds_so_far)                      -- Dead code
 325       | otherwise
 326       = (combined_usage, new_bind : binds_so_far)
 327       where
 328         total_usage                   = combineUsageDetails body_usage rhs_usage
 329         (combined_usage, tagged_bndr) = tagBinder total_usage bndr
 330         new_bind                      = NonRec tagged_bndr rhs'
 331
 332         -- Recursive SCC
 333     do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
 334       | not (any (`usedIn` body_usage) bndrs)           -- NB: look at body_usage, not total_usage
 335       = (body_usage, binds_so_far)                      -- Dead code
 336       | otherwise
 337       = (combined_usage, final_bind:binds_so_far)
 338       where
 339         details                        = [details   | (details, _, _) <- cycle]
 340         bndrs                          = [bndr      | (bndr, _, _)      <- details]
 341         rhs_usages                     = [rhs_usage | (_, rhs_usage, _) <- details]
 342         total_usage                    = foldr combineUsageDetails body_usage rhs_usages
 343         (combined_usage, tagged_bndrs) = tagBinders total_usage bndrs
 344         final_bind                     = Rec (reOrderRec env new_cycle)
 345
 346         new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_bndrs cycle)
 347         mk_new_bind tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys)
 348 \end{code}
 349
 350 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
 351 strongly connected component (there's guaranteed to be a cycle).  It returns the
 352 same pairs, but
 353         a) in a better order,
 354         b) with some of the Ids having a IMustNotBeINLINEd pragma
 355
 356 The "no-inline" Ids are sufficient to break all cycles in the SCC.  This means
 357 that the simplifier can guarantee not to loop provided it never records an inlining
 358 for these no-inline guys.
 359
 360 Furthermore, the order of the binds is such that if we neglect dependencies
 361 on the no-inline Ids then the binds are topologically sorted.  This means
 362 that the simplifier will generally do a good job if it works from top bottom,
 363 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
 364
 365 ==============
 366 [June 98: I don't understand the following paragraphs, and I've
 367           changed the a=b case again so that it isn't a special case any more.]
 368
 369 Here's a case that bit me:
 370
 371         letrec
 372                 a = b
 373                 b = \x. BIG
 374         in
 375         ...a...a...a....
 376
 377 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
 378
 379 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
 380 Perhaps something cleverer would suffice.
 381 ===============
 382
 383 You might think that you can prevent non-termination simply by making
 384 sure that we simplify a recursive binding's RHS in an environment that
 385 simply clones the recursive Id.  But no.  Consider
 386
 387                 letrec f = \x -> let z = f x' in ...
 388
 389                 in
 390                 let n = f y
 391                 in
 392                 case n of { ... }
 393
 394 We bind n to its *simplified* RHS, we then *re-simplify* it when
 395 we inline n.  Then we may well inline f; and then the same thing
 396 happens with z!
 397
 398 I don't think it's possible to prevent non-termination by environment
 399 manipulation in this way.  Apart from anything else, successive
 400 iterations of the simplifier may unroll recursive loops in cases like
 401 that above.  The idea of beaking every recursive loop with an
 402 IMustNotBeINLINEd pragma is much much better.
 403
 404
 405 \begin{code}
 406 reOrderRec
 407         :: OccEnv
 408         -> SCC (Node Details2)
 409         -> [Details2]
 410                         -- Sorted into a plausible order.  Enough of the Ids have
 411                         --      dontINLINE pragmas that there are no loops left.
 412
 413         -- Non-recursive case
 414 reOrderRec env (AcyclicSCC (bind, _, _)) = [bind]
 415
 416         -- Common case of simple self-recursion
 417 reOrderRec env (CyclicSCC [bind])
 418   = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
 419   where
 420     ((tagged_bndr, rhs), _, _) = bind
 421
 422 reOrderRec env (CyclicSCC (bind : binds))
 423   =     -- Choose a loop breaker, mark it no-inline,
 424         -- do SCC analysis on the rest, and recursively sort them out
 425     concat (map (reOrderRec env) (stronglyConnCompR unchosen))
 426     ++
 427     [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
 428
 429   where
 430     (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
 431     (tagged_bndr, rhs)      = chosen_pair
 432
 433         -- This loop looks for the bind with the lowest score
 434         -- to pick as the loop  breaker.  The rest accumulate in
 435     choose_loop_breaker (details,_,_) loop_sc acc []
 436         = (details, acc)        -- Done
 437
 438     choose_loop_breaker loop_bind loop_sc acc (bind : binds)
 439         | sc < loop_sc  -- Lower score so pick this new one
 440         = choose_loop_breaker bind sc (loop_bind : acc) binds
 441
 442         | otherwise     -- No lower so don't pick it
 443         = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
 444         where
 445           sc = score bind
 446
 447     score :: Node Details2 -> Int       -- Higher score => less likely to be picked as loop breaker
 448     score ((bndr, rhs), _, _)
 449         | exprIsTrivial rhs &&
 450           not (isExportedId bndr)  = 3          -- Practically certain to be inlined
 451         | inlineCandidate bndr rhs = 3          -- Likely to be inlined
 452         | not_fun_ty (idType bndr) = 2          -- Data types help with cases
 453         | not (isEmptyCoreRules (idSpecialisation bndr)) = 1
 454                 -- Avoid things with specialisations; we'd like
 455                 -- to take advantage of them in the subsequent bindings
 456         | otherwise = 0
 457
 458     inlineCandidate :: Id -> CoreExpr -> Bool
 459     inlineCandidate id (Note InlineMe _) = True
 460     inlineCandidate id rhs               = case idOccInfo id of
 461                                                 OneOcc _ _ -> True
 462                                                 other      -> False
 463
 464         -- Real example (the Enum Ordering instance from PrelBase):
 465         --      rec     f = \ x -> case d of (p,q,r) -> p x
 466         --              g = \ x -> case d of (p,q,r) -> q x
 467         --              d = (v, f, g)
 468         --
 469         -- Here, f and g occur just once; but we can't inline them into d.
 470         -- On the other hand we *could* simplify those case expressions if
 471         -- we didn't stupidly choose d as the loop breaker.
 472         -- But we won't because constructor args are marked "Many".
 473
 474     not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty))
 475                   where
 476                     (_, rho_ty) = splitForAllTys ty
 477 \end{code}
 478
 479 @occAnalRhs@ deals with the question of bindings where the Id is marked
 480 by an INLINE pragma.  For these we record that anything which occurs
 481 in its RHS occurs many times.  This pessimistically assumes that ths
 482 inlined binder also occurs many times in its scope, but if it doesn't
 483 we'll catch it next time round.  At worst this costs an extra simplifier pass.
 484 ToDo: try using the occurrence info for the inline'd binder.
 485
 486 [March 97] We do the same for atomic RHSs.  Reason: see notes with reOrderRec.
 487 [June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with reOrderRec.
 488
 489
 490 \begin{code}
 491 occAnalRhs :: OccEnv
 492            -> Id -> CoreExpr    -- Binder and rhs
 493            -> (UsageDetails, CoreExpr)
 494
 495 occAnalRhs env id rhs
 496   = (final_usage, rhs')
 497   where
 498     (rhs_usage, rhs') = occAnal (zapCtxt env) rhs
 499
 500         -- [March 98] A new wrinkle is that if the binder has specialisations inside
 501         -- it then we count the specialised Ids as "extra rhs's".  That way
 502         -- the "parent" keeps the specialised "children" alive.  If the parent
 503         -- dies (because it isn't referenced any more), then the children will
 504         -- die too unless they are already referenced directly.
 505
 506     final_usage = foldVarSet add rhs_usage (idRuleVars id)
 507     add v u = addOneOcc u v noBinderInfo        -- Give a non-committal binder info
 508                                                 -- (i.e manyOcc) because many copies
 509                                                 -- of the specialised thing can appear
 510 \end{code}
 511
 512 Expressions
 513 ~~~~~~~~~~~
 514 \begin{code}
 515 occAnal :: OccEnv
 516         -> CoreExpr
 517         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
 518             CoreExpr)
 519
 520 occAnal env (Type t)  = (emptyDetails, Type t)
 521
 522 occAnal env (Var v)
 523   = (var_uds, Var v)
 524   where
 525     var_uds | isCandidate env v = unitVarEnv v funOccZero
 526             | otherwise         = emptyDetails
 527
 528     -- At one stage, I gathered the idRuleVars for v here too,
 529     -- which in a way is the right thing to do.
 530     -- But that went wrong right after specialisation, when
 531     -- the *occurrences* of the overloaded function didn't have any
 532     -- rules in them, so the *specialised* versions looked as if they
 533     -- weren't used at all.
 534
 535 \end{code}
 536
 537 We regard variables that occur as constructor arguments as "dangerousToDup":
 538
 539 \begin{verbatim}
 540 module A where
 541 f x = let y = expensive x in
 542       let z = (True,y) in
 543       (case z of {(p,q)->q}, case z of {(p,q)->q})
 544 \end{verbatim}
 545
 546 We feel free to duplicate the WHNF (True,y), but that means
 547 that y may be duplicated thereby.
 548
 549 If we aren't careful we duplicate the (expensive x) call!
 550 Constructors are rather like lambdas in this way.
 551
 552 \begin{code}
 553 occAnal env expr@(Lit lit) = (emptyDetails, expr)
 554 \end{code}
 555
 556 \begin{code}
 557 occAnal env (Note InlineMe body)
 558   = case occAnal env body of { (usage, body') ->
 559     (mapVarEnv markMany usage, Note InlineMe body')
 560     }
 561
 562 occAnal env (Note note@(SCC cc) body)
 563   = case occAnal env body of { (usage, body') ->
 564     (mapVarEnv markInsideSCC usage, Note note body')
 565     }
 566
 567 occAnal env (Note note body)
 568   = case occAnal env body of { (usage, body') ->
 569     (usage, Note note body')
 570     }
 571 \end{code}
 572
 573 \begin{code}
 574 occAnal env app@(App fun arg)
 575   = occAnalApp env (collectArgs app)
 576
 577 -- Ignore type variables altogether
 578 --   (a) occurrences inside type lambdas only not marked as InsideLam
 579 --   (b) type variables not in environment
 580
 581 occAnal env expr@(Lam x body) | isTyVar x
 582   = case occAnal env body of { (body_usage, body') ->
 583     (body_usage, Lam x body')
 584     }
 585
 586 -- For value lambdas we do a special hack.  Consider
 587 --      (\x. \y. ...x...)
 588 -- If we did nothing, x is used inside the \y, so would be marked
 589 -- as dangerous to dup.  But in the common case where the abstraction
 590 -- is applied to two arguments this is over-pessimistic.
 591 -- So instead, we just mark each binder with its occurrence
 592 -- info in the *body* of the multiple lambda.
 593 -- Then, the simplifier is careful when partially applying lambdas.
 594
 595 occAnal env expr@(Lam _ _)
 596   = case occAnal (env_body `addNewCands` binders) body of { (body_usage, body') ->
 597     let
 598         (final_usage, tagged_binders) = tagBinders body_usage binders
 599         --      URGH!  Sept 99: we don't seem to be able to use binders' here, because
 600         --      we get linear-typed things in the resulting program that we can't handle yet.
 601         --      (e.g. PrelShow)  TODO
 602
 603         really_final_usage = if linear then
 604                                 final_usage
 605                              else
 606                                 mapVarEnv markInsideLam final_usage
 607     in
 608     (really_final_usage,
 609      mkLams tagged_binders body') }
 610   where
 611     (binders, body)    = collectBinders expr
 612     (linear, env_body, binders') = oneShotGroup env binders
 613
 614 occAnal env (Case scrut bndr alts)
 615   = case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts')   ->
 616     case occAnal (zapCtxt env) scrut           of { (scrut_usage, scrut') ->
 617     let
 618         alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
 619         alts_usage' = addCaseBndrUsage alts_usage
 620         (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
 621         total_usage = scrut_usage `combineUsageDetails` alts_usage1
 622     in
 623     total_usage `seq` (total_usage, Case scrut' tagged_bndr alts') }}
 624   where
 625     alt_env = env `addNewCand` bndr
 626
 627         -- The case binder gets a usage of either "many" or "dead", never "one".
 628         -- Reason: we like to inline single occurrences, to eliminate a binding,
 629         -- but inlining a case binder *doesn't* eliminate a binding.
 630         -- We *don't* want to transform
 631         --      case x of w { (p,q) -> f w }
 632         -- into
 633         --      case x of w { (p,q) -> f (p,q) }
 634     addCaseBndrUsage usage = case lookupVarEnv usage bndr of
 635                                 Nothing  -> usage
 636                                 Just occ -> extendVarEnv usage bndr (markMany occ)
 637
 638 occAnal env (Let bind body)
 639   = case occAnal new_env body            of { (body_usage, body') ->
 640     case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
 641        (final_usage, mkLets new_binds body') }}
 642   where
 643     new_env = env `addNewCands` (bindersOf bind)
 644
 645 occAnalArgs env args
 646   = case mapAndUnzip (occAnal arg_env) args of  { (arg_uds_s, args') ->
 647     (foldr combineUsageDetails emptyDetails arg_uds_s, args')}
 648   where
 649     arg_env = zapCtxt env
 650 \end{code}
 651
 652 Applications are dealt with specially because we want
 653 the "build hack" to work.
 654
 655 \begin{code}
 656 -- Hack for build, fold, runST
 657 occAnalApp env (Var fun, args)
 658   = case args_stuff of { (args_uds, args') ->
 659     let
 660         final_uds = fun_uds `combineUsageDetails` args_uds
 661     in
 662     (final_uds, mkApps (Var fun) args') }
 663   where
 664     fun_uniq = idUnique fun
 665
 666     fun_uds | isCandidate env fun = unitVarEnv fun funOccZero
 667             | otherwise           = emptyDetails
 668
 669     args_stuff  | fun_uniq == buildIdKey    = appSpecial env 2 [True,True]  args
 670                 | fun_uniq == augmentIdKey  = appSpecial env 2 [True,True]  args
 671                 | fun_uniq == foldrIdKey    = appSpecial env 3 [False,True] args
 672                 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True]    args
 673
 674                 | isDataConId fun           = case occAnalArgs env args of
 675                                                 (arg_uds, args') -> (mapVarEnv markMany arg_uds, args')
 676                                                    -- We mark the free vars of the argument of a constructor as "many"
 677                                                    -- This means that nothing gets inlined into a constructor argument
 678                                                    -- position, which is what we want.  Typically those constructor
 679                                                    -- arguments are just variables, or trivial expressions.
 680
 681                 | otherwise                 = occAnalArgs env args
 682
 683
 684 occAnalApp env (fun, args)
 685   = case occAnal (zapCtxt env) fun of           { (fun_uds, fun') ->
 686     case occAnalArgs env args of                { (args_uds, args') ->
 687     let
 688         final_uds = fun_uds `combineUsageDetails` args_uds
 689     in
 690     (final_uds, mkApps fun' args') }}
 691
 692 appSpecial :: OccEnv -> Int -> CtxtTy -> [CoreExpr] -> (UsageDetails, [CoreExpr])
 693 appSpecial env n ctxt args
 694   = go n args
 695   where
 696     go n [] = (emptyDetails, [])        -- Too few args
 697
 698     go 1 (arg:args)                     -- The magic arg
 699       = case occAnal (setCtxt env ctxt) arg of  { (arg_uds, arg') ->
 700         case occAnalArgs env args of            { (args_uds, args') ->
 701         (combineUsageDetails arg_uds args_uds, arg':args') }}
 702
 703     go n (arg:args)
 704       = case occAnal env arg of         { (arg_uds, arg') ->
 705         case go (n-1) args of           { (args_uds, args') ->
 706         (combineUsageDetails arg_uds args_uds, arg':args') }}
 707 \end{code}
 708
 709
 710 Case alternatives
 711 ~~~~~~~~~~~~~~~~~
 712 \begin{code}
 713 occAnalAlt env (con, bndrs, rhs)
 714   = case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') ->
 715     let
 716         (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
 717     in
 718     (final_usage, (con, tagged_bndrs, rhs')) }
 719 \end{code}
 720
 721
 722 %************************************************************************
 723 %*                                                                      *
 724 \subsection[OccurAnal-types]{Data types}
 725 %*                                                                      *
 726 %************************************************************************
 727
 728 \begin{code}
 729 -- We gather inforamtion for variables that are either
 730 --      (a) in scope or
 731 --      (b) interesting
 732
 733 data OccEnv =
 734   OccEnv (Id -> Bool)   -- Tells whether an Id occurrence is interesting,
 735          IdSet          -- In-scope Ids
 736          CtxtTy         -- Tells about linearity
 737
 738 type CtxtTy = [Bool]
 739         -- []           No info
 740         --
 741         -- True:ctxt    Analysing a function-valued expression that will be
 742         --                      applied just once
 743         --
 744         -- False:ctxt   Analysing a function-valued expression that may
 745         --                      be applied many times; but when it is,
 746         --                      the CtxtTy inside applies
 747
 748 isCandidate :: OccEnv -> Id -> Bool
 749 isCandidate (OccEnv ifun cands _) id = id `elemVarSet` cands || ifun id
 750
 751 addNewCands :: OccEnv -> [Id] -> OccEnv
 752 addNewCands (OccEnv ifun cands ctxt) ids
 753   = OccEnv ifun (cands `unionVarSet` mkVarSet ids) ctxt
 754
 755 addNewCand :: OccEnv -> Id -> OccEnv
 756 addNewCand (OccEnv ifun cands ctxt) id
 757   = OccEnv ifun (extendVarSet cands id) ctxt
 758
 759 setCtxt :: OccEnv -> CtxtTy -> OccEnv
 760 setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt
 761
 762 oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr])
 763         -- True <=> this is a one-shot linear lambda group
 764         -- The [CoreBndr] are the binders.
 765
 766         -- The result binders have one-shot-ness set that they might not have had originally.
 767         -- This happens in (build (\cn -> e)).  Here the occurrence analyser
 768         -- linearity context knows that c,n are one-shot, and it records that fact in
 769         -- the binder. This is useful to guide subsequent float-in/float-out tranformations
 770
 771 oneShotGroup (OccEnv ifun cands ctxt) bndrs
 772   = case go ctxt bndrs [] of
 773         (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv ifun cands new_ctxt, new_bndrs)
 774   where
 775     is_one_shot b = isId b && isOneShotLambda b
 776
 777     go ctxt [] rev_bndrs = (ctxt, reverse rev_bndrs)
 778
 779     go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
 780         | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
 781         where
 782           bndr' | lin_ctxt  = setOneShotLambda bndr
 783                 | otherwise = bndr
 784
 785     go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
 786
 787
 788 zapCtxt env@(OccEnv ifun cands []) = env
 789 zapCtxt     (OccEnv ifun cands _ ) = OccEnv ifun cands []
 790
 791 type UsageDetails = IdEnv BinderInfo    -- A finite map from ids to their usage
 792
 793 combineUsageDetails, combineAltsUsageDetails
 794         :: UsageDetails -> UsageDetails -> UsageDetails
 795
 796 combineUsageDetails usage1 usage2
 797   = plusVarEnv_C addBinderInfo usage1 usage2
 798
 799 combineAltsUsageDetails usage1 usage2
 800   = plusVarEnv_C orBinderInfo usage1 usage2
 801
 802 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
 803 addOneOcc usage id info
 804   = plusVarEnv_C addBinderInfo usage (unitVarEnv id info)
 805         -- ToDo: make this more efficient
 806
 807 emptyDetails = (emptyVarEnv :: UsageDetails)
 808
 809 unitDetails id info = (unitVarEnv id info :: UsageDetails)
 810
 811 usedIn :: Id -> UsageDetails -> Bool
 812 v `usedIn` details =  isExportedId v || v `elemVarEnv` details
 813
 814 tagBinders :: UsageDetails          -- Of scope
 815            -> [Id]                  -- Binders
 816            -> (UsageDetails,        -- Details with binders removed
 817               [IdWithOccInfo])    -- Tagged binders
 818
 819 tagBinders usage binders
 820  = let
 821      usage' = usage `delVarEnvList` binders
 822      uss    = map (setBinderOcc usage) binders
 823    in
 824    usage' `seq` (usage', uss)
 825
 826 tagBinder :: UsageDetails           -- Of scope
 827           -> Id                     -- Binders
 828           -> (UsageDetails,         -- Details with binders removed
 829               IdWithOccInfo)        -- Tagged binders
 830
 831 tagBinder usage binder
 832  = let
 833      usage'  = usage `delVarEnv` binder
 834      binder' = setBinderOcc usage binder
 835    in
 836    usage' `seq` (usage', binder')
 837
 838
 839 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
 840 setBinderOcc usage bndr
 841   | isTyVar bndr      = bndr
 842   | isExportedId bndr
 843   = -- Don't use local usage info for visible-elsewhere things
 844     -- BUT *do* erase any IAmALoopBreaker annotation, because we're
 845     -- about to re-generate it and it shouldn't be "sticky"
 846     case idOccInfo bndr of
 847         NoOccInfo -> bndr
 848         other     -> setIdOccInfo bndr NoOccInfo
 849
 850   | otherwise         = setIdOccInfo bndr occ_info
 851   where
 852     occ_info = case lookupVarEnv usage bndr of
 853                  Nothing   -> IAmDead
 854                  Just info -> binderInfoToOccInfo info
 855
 856 markBinderInsideLambda :: CoreBndr -> CoreBndr
 857 markBinderInsideLambda bndr
 858   | isTyVar bndr
 859   = bndr
 860
 861   | otherwise
 862   = case idOccInfo bndr of
 863         OneOcc _ once -> bndr `setIdOccInfo` OneOcc insideLam once
 864         other         -> bndr
 865
 866 funOccZero = funOccurrence 0
 867 \end{code}