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