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