ghc/compiler/simplCore/OccurAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[OccurAnal]{Occurrence analysis pass}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 The occurrence analyser re-typechecks a core expression, returning a new
  11 core expression with (hopefully) improved usage information.
  12
  13 \begin{code}
  14 #include "HsVersions.h"
  15
  16 module OccurAnal (
  17         occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
  18     ) where
  19
  20 IMP_Ubiq(){-uitous-}
  21 IMPORT_1_3(List(partition))
  22
  23 import BinderInfo
  24 import CmdLineOpts      ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
  25 import CoreSyn
  26 import Digraph          ( stronglyConnComp, stronglyConnCompR, SCC(..) )
  27 import Id               ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
  28                           idType, idUnique, SYN_IE(Id),
  29                           emptyIdSet, unionIdSets, mkIdSet,
  30                           unitIdSet, elementOfIdSet,
  31                           addOneToIdSet, SYN_IE(IdSet),
  32                           nullIdEnv, unitIdEnv, combineIdEnvs,
  33                           delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
  34                           mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
  35                           GenId{-instance Eq-}
  36                         )
  37 import Name             ( isExported, isLocallyDefined )
  38 import Type             ( getFunTy_maybe, splitForAllTy )
  39 import Maybes           ( maybeToBool )
  40 import Outputable       ( PprStyle(..), Outputable(..){-instance * (,) -} )
  41 import PprCore
  42 import PprType          ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
  43 import Pretty           ( Doc, vcat, ptext, nest, punctuate, comma, hcat, text )
  44 import TyVar            ( GenTyVar{-instance Eq-} )
  45 import Unique           ( Unique{-instance Eq-}, u2i )
  46 import UniqFM           ( keysUFM )
  47 import Util             ( assoc, zipEqual, zipWithEqual, Ord3(..)
  48                         , pprTrace, panic
  49 #ifdef DEBUG
  50                         , assertPanic
  51 #endif
  52                         )
  53
  54 isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
  55 \end{code}
  56
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection[OccurAnal-types]{Data types}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65 data OccEnv =
  66   OccEnv
  67     Bool        -- Keep-unused-bindings flag
  68                 -- False <=> OK to chuck away binding
  69                 --           and ignore occurrences within it
  70     Bool        -- Keep-spec-pragma-ids flag
  71                 -- False <=> OK to chuck away spec pragma bindings
  72                 --           and ignore occurrences within it
  73     Bool        -- Keep-conjurable flag
  74                 -- False <=> OK to throw away *dead*
  75                 -- "conjurable" Ids; at the moment, that
  76                 -- *only* means constant methods, which
  77                 -- are top-level.  A use of a "conjurable"
  78                 -- Id may appear out of thin air -- e.g.,
  79                 -- specialiser conjuring up refs to const methods.
  80     Bool        -- IgnoreINLINEPragma flag
  81                 -- False <=> OK to use INLINEPragma information
  82                 -- True  <=> ignore INLINEPragma information
  83
  84     (Id -> IdSet -> Bool)       -- Tells whether an Id occurrence is interesting,
  85                                 -- given the set of in-scope variables
  86
  87     IdSet       -- In-scope Ids
  88
  89
  90 addNewCands :: OccEnv -> [Id] -> OccEnv
  91 addNewCands (OccEnv kd ks kc ip ifun cands) ids
  92   = OccEnv kd ks kc ip ifun (cands `unionIdSets` mkIdSet ids)
  93
  94 addNewCand :: OccEnv -> Id -> OccEnv
  95 addNewCand (OccEnv ks kd kc ip ifun cands) id
  96   = OccEnv kd ks kc ip ifun (addOneToIdSet cands id)
  97
  98 isCandidate :: OccEnv -> Id -> Bool
  99 isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands
 100
 101 inlineMe :: OccEnv -> Id -> Bool
 102 inlineMe env id
 103   = {-  See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
 104         not ignore_inline_prag &&
 105     -}
 106     idWantsToBeINLINEd id
 107
 108 keepUnusedBinding :: OccEnv -> Id -> Bool
 109 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
 110   = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
 111
 112 keepBecauseConjurable :: OccEnv -> Id -> Bool
 113 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
 114   = False
 115     {- keep_conjurable && isConstMethodId binder -}
 116
 117 type UsageDetails = IdEnv BinderInfo    -- A finite map from ids to their usage
 118
 119 combineUsageDetails, combineAltsUsageDetails
 120         :: UsageDetails -> UsageDetails -> UsageDetails
 121
 122 combineUsageDetails usage1 usage2
 123   = combineIdEnvs addBinderInfo usage1 usage2
 124
 125 combineAltsUsageDetails usage1 usage2
 126   = combineIdEnvs orBinderInfo usage1 usage2
 127
 128 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
 129 addOneOcc usage id info
 130   = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
 131         -- ToDo: make this more efficient
 132
 133 emptyDetails = (nullIdEnv :: UsageDetails)
 134
 135 unitDetails id info = (unitIdEnv id info :: UsageDetails)
 136
 137 tagBinders :: UsageDetails          -- Of scope
 138            -> [Id]                  -- Binders
 139            -> (UsageDetails,        -- Details with binders removed
 140               [(Id,BinderInfo)])    -- Tagged binders
 141
 142 tagBinders usage binders =
 143  let
 144   usage' = usage `delManyFromIdEnv` binders
 145   uss    = [ (binder, usage_of usage binder) | binder <- binders ]
 146  in
 147  if isNullIdEnv usage' then
 148     (usage', uss)
 149  else
 150     (usage', uss)
 151 {-
 152   = (usage `delManyFromIdEnv` binders,
 153      [ (binder, usage_of usage binder) | binder <- binders ]
 154     )
 155 -}
 156 tagBinder :: UsageDetails           -- Of scope
 157           -> Id                     -- Binders
 158           -> (UsageDetails,         -- Details with binders removed
 159               (Id,BinderInfo))      -- Tagged binders
 160
 161 tagBinder usage binder =
 162  let
 163    usage'  = usage `delOneFromIdEnv` binder
 164    us      = usage_of usage binder
 165    cont =
 166     if isNullIdEnv usage' then  -- bogus test to force evaluation.
 167        (usage', (binder, us))
 168     else
 169        (usage', (binder, us))
 170  in
 171  case us of { DeadCode -> cont; _ -> cont }
 172
 173 --   (binder, usage_of usage binder)
 174
 175
 176 usage_of usage binder
 177   | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
 178   | otherwise
 179   = case (lookupIdEnv usage binder) of
 180       Nothing   -> DeadCode
 181       Just info -> info
 182
 183 isNeeded env usage binder
 184   = case (usage_of usage binder) of
 185       DeadCode  -> keepUnusedBinding env binder -- Maybe keep it anyway
 186       other     -> True
 187 \end{code}
 188
 189
 190 %************************************************************************
 191 %*                                                                      *
 192 \subsection[OccurAnal-main]{Counting occurrences: main function}
 193 %*                                                                      *
 194 %************************************************************************
 195
 196 Here's the externally-callable interface:
 197
 198 \begin{code}
 199 occurAnalyseBinds
 200         :: [CoreBinding]                -- input
 201         -> (SimplifierSwitch -> Bool)
 202         -> [SimplifiableCoreBinding]    -- output
 203
 204 occurAnalyseBinds binds simplifier_sw_chkr
 205   | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
 206                                      (vcat (map ppr_bind binds'))
 207                                      binds'
 208   | otherwise             = binds'
 209   where
 210     (_, binds') = doo initial_env binds
 211
 212     initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
 213                          (simplifier_sw_chkr KeepSpecPragmaIds)
 214                          (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
 215                          (simplifier_sw_chkr IgnoreINLINEPragma)
 216                          (\id in_scope -> isLocallyDefined id)  -- Anything local is interesting
 217                          emptyIdSet                             -- Not actually used
 218
 219     doo env [] = (emptyDetails, [])
 220     doo env (bind:binds)
 221       = (final_usage, new_binds ++ the_rest)
 222       where
 223         new_env                  = env `addNewCands` (bindersOf bind)
 224         (binds_usage, the_rest)  = doo new_env binds
 225         (final_usage, new_binds) = occAnalBind env bind binds_usage
 226
 227         -- This really ought to be done properly by PprCore, but
 228         -- it isn't.  pprCoreBinding only works on Id binders, and
 229         -- the general case is complicated by the fact that it has to work
 230         -- for interface files too.  Sigh
 231
 232 ppr_bind bind@(NonRec binder expr)
 233   = ppr PprDebug bind
 234
 235 ppr_bind bind@(Rec binds)
 236   = vcat [ptext SLIT("Rec {"),
 237               nest 2 (ppr PprDebug bind),
 238               ptext SLIT("end Rec }")]
 239 \end{code}
 240
 241 \begin{code}
 242 occurAnalyseExpr :: (Id -> Bool)        -- Tells if a variable is interesting
 243                  -> CoreExpr
 244                  -> (IdEnv BinderInfo,  -- Occ info for interesting free vars
 245                      SimplifiableCoreExpr)
 246
 247 occurAnalyseExpr interesting expr
 248   = occAnal initial_env expr
 249   where
 250     initial_env = OccEnv False {- Drop unused bindings -}
 251                          False {- Drop SpecPragmaId bindings -}
 252                          True  {- Keep conjurable Ids -}
 253                          False {- Do not ignore INLINE Pragma -}
 254                          (\id locals -> interesting id || elementOfIdSet id locals)
 255                          emptyIdSet
 256
 257 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
 258 occurAnalyseGlobalExpr expr
 259   =     -- Top level expr, so no interesting free vars, and
 260         -- discard occurence info returned
 261     snd (occurAnalyseExpr (\_ -> False) expr)
 262 \end{code}
 263
 264 %************************************************************************
 265 %*                                                                      *
 266 \subsection[OccurAnal-main]{Counting occurrences: main function}
 267 %*                                                                      *
 268 %************************************************************************
 269
 270 Bindings
 271 ~~~~~~~~
 272
 273 \begin{code}
 274 type Node details = (details, Int, [Int])       -- The Ints are gotten from the Unique,
 275                                                 -- which is gotten from the Id.
 276 type Details1     = (Id, (UsageDetails, SimplifiableCoreExpr))
 277 type Details2     = ((Id, BinderInfo), SimplifiableCoreExpr)
 278
 279
 280 occAnalBind :: OccEnv
 281             -> CoreBinding
 282             -> UsageDetails             -- Usage details of scope
 283             -> (UsageDetails,           -- Of the whole let(rec)
 284                 [SimplifiableCoreBinding])
 285
 286 occAnalBind env (NonRec binder rhs) body_usage
 287   | isNeeded env body_usage binder              -- It's mentioned in body
 288   = (final_body_usage `combineUsageDetails` rhs_usage,
 289      [NonRec tagged_binder rhs'])
 290
 291   | otherwise                   -- Not mentioned, so drop dead code
 292   = (body_usage, [])
 293
 294   where
 295     binder'                           = nukeNoInlinePragma binder
 296     (rhs_usage, rhs')                 = occAnalRhs env binder' rhs
 297     (final_body_usage, tagged_binder) = tagBinder body_usage binder'
 298 \end{code}
 299
 300 Dropping dead code for recursive bindings is done in a very simple way:
 301
 302         the entire set of bindings is dropped if none of its binders are
 303         mentioned in its body; otherwise none are.
 304
 305 This seems to miss an obvious improvement.
 306 @
 307         letrec  f = ...g...
 308                 g = ...f...
 309         in
 310         ...g...
 311
 312 ===>
 313
 314         letrec f = ...g...
 315                g = ...(...g...)...
 316         in
 317         ...g...
 318 @
 319
 320 Now @f@ is unused. But dependency analysis will sort this out into a
 321 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
 322 It isn't easy to do a perfect job in one blow.  Consider
 323
 324 @
 325         letrec f = ...g...
 326                g = ...h...
 327                h = ...k...
 328                k = ...m...
 329                m = ...m...
 330         in
 331         ...m...
 332 @
 333
 334
 335 \begin{code}
 336 occAnalBind env (Rec pairs) body_usage
 337   = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
 338   where
 339     pp_scc (CyclicSCC cycle) = hcat [text "Cyclic ", hcat (punctuate comma (map pp_item cycle))]
 340     pp_scc (AcyclicSCC item) = hcat [text "Acyclic ", pp_item item]
 341     pp_item (_, bndr, _)     = ppr PprDebug bndr
 342
 343     binders = map fst pairs
 344     new_env = env `addNewCands` binders
 345
 346     analysed_pairs :: [Details1]
 347     analysed_pairs  = [(nukeNoInlinePragma bndr, occAnalRhs new_env bndr rhs) | (bndr,rhs) <- pairs]
 348
 349     sccs :: [SCC (Node Details1)]
 350     sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
 351
 352
 353     ---- stuff for dependency analysis of binds -------------------------------
 354     edges :: [Node Details1]
 355     edges = _scc_ "occAnalBind.assoc"
 356             [ (pair, IBOX(u2i (idUnique id)), edges_from rhs_usage)
 357             | pair@(id, (rhs_usage, rhs)) <- analysed_pairs
 358             ]
 359
 360         -- (a -> b) means a mentions b
 361         -- Given the usage details (a UFM that gives occ info for each free var of
 362         -- the RHS) we can get the list of free vars -- or rather their Int keys --
 363         -- by just extracting the keys from the finite map.  Grimy, but fast.
 364         -- Previously we had this:
 365         --      [ bndr | bndr <- bndrs,
 366         --               maybeToBool (lookupIdEnv rhs_usage bndr)]
 367         -- which has n**2 cost, and this meant that edges_from alone
 368         -- consumed 10% of total runtime!
 369     edges_from :: UsageDetails -> [Int]
 370     edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
 371                            keysUFM rhs_usage
 372
 373     ---- stuff to "re-constitute" bindings from dependency-analysis info ------
 374
 375         -- Non-recursive SCC
 376     do_final_bind (AcyclicSCC ((bndr, (rhs_usage, rhs')), _, _)) (body_usage, binds_so_far)
 377       | isNeeded env body_usage bndr
 378       = (combined_usage, new_bind : binds_so_far)
 379       | otherwise
 380       = (body_usage, binds_so_far)                      -- Dead code
 381       where
 382         total_usage                   = combineUsageDetails body_usage rhs_usage
 383         (combined_usage, tagged_bndr) = tagBinder total_usage bndr
 384         new_bind                      = NonRec tagged_bndr rhs'
 385
 386         -- Recursive SCC
 387     do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
 388       | any (isNeeded env body_usage) bndrs
 389       = (combined_usage, final_bind:binds_so_far)
 390       | otherwise
 391       = (body_usage, binds_so_far)                      -- Dead code
 392       where
 393         pairs                            = [pair      | (pair, _, _) <- cycle]
 394         bndrs                            = [bndr      | (bndr, _)           <- pairs]
 395         rhs_usages                       = [rhs_usage | (_, (rhs_usage, _)) <- pairs]
 396         total_usage                      = foldr combineUsageDetails body_usage rhs_usages
 397         (combined_usage, tagged_binders) = tagBinders total_usage bndrs
 398         final_bind                       = Rec (reOrderRec env new_cycle)
 399
 400         new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle)
 401         mk_new_bind tagged_bndr ((_, (_, rhs')), key, keys) = ((tagged_bndr, rhs'), key, keys)
 402 \end{code}
 403
 404 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
 405 strongly connected component (there's guaranteed to be a cycle).  It returns the
 406 same pairs, but
 407         a) in a better order,
 408         b) with some of the Ids having a IMustNotBeINLINEd pragma
 409
 410 The "no-inline" Ids are sufficient to break all cycles in the SCC.  This means
 411 that the simplifier can guarantee not to loop provided it never records an inlining
 412 for these no-inline guys.
 413
 414 Furthermore, the order of the binds is such that if we neglect dependencies
 415 on the no-inline Ids then the binds are topologically sorted.  This means
 416 that the simplifier will generally do a good job if it works from top bottom,
 417 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
 418
 419 Here's a case that bit me:
 420
 421         letrec
 422                 a = b
 423                 b = \x. BIG
 424         in
 425         ...a...a...a....
 426
 427 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
 428
 429 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
 430 Perhaps something cleverer would suffice.
 431
 432 You might think that you can prevent non-termination simply by making
 433 sure that we simplify a recursive binding's RHS in an environment that
 434 simply clones the recursive Id.  But no.  Consider
 435
 436                 letrec f = \x -> let z = f x' in ...
 437
 438                 in
 439                 let n = f y
 440                 in
 441                 case n of { ... }
 442
 443 We bind n to its *simplified* RHS, we then *re-simplify* it when
 444 we inline n.  Then we may well inline f; and then the same thing
 445 happens with z!
 446
 447 I don't think it's possible to prevent non-termination by environment
 448 manipulation in this way.  Apart from anything else, successive
 449 iterations of the simplifier may unroll recursive loops in cases like
 450 that above.  The idea of beaking every recursive loop with an
 451 IMustNotBeINLINEd pragma is much much better.
 452
 453
 454 \begin{code}
 455 reOrderRec
 456         :: OccEnv
 457         -> SCC (Node Details2)
 458         -> [Details2]
 459                         -- Sorted into a plausible order.  Enough of the Ids have
 460                         --      dontINLINE pragmas that there are no loops left.
 461
 462         -- Non-recursive case
 463 reOrderRec env (AcyclicSCC (pair, _, _)) = [pair]
 464
 465         -- Common case of simple self-recursion
 466 reOrderRec env (CyclicSCC [bind])
 467   = [((addNoInlinePragma bndr, occ_info), rhs)]
 468   where
 469     (((bndr,occ_info), rhs), _, _) = bind
 470
 471 reOrderRec env (CyclicSCC binds)
 472   =     -- Choose a loop breaker, mark it no-inline,
 473         -- do SCC analysis on the rest, and recursively sort them out
 474     concat (map (reOrderRec env) (stronglyConnCompR unchosen))
 475     ++
 476     [((addNoInlinePragma bndr, occ_info), rhs)]
 477
 478   where
 479     (chosen_pair, unchosen) = choose_loop_breaker binds
 480     ((bndr,occ_info), rhs)  = chosen_pair
 481
 482         -- Choosing the loop breaker; heursitic
 483     choose_loop_breaker (bind@(pair, _, _) : rest)
 484         |  not (null rest) &&
 485            bad_choice pair
 486         =  (chosen, bind : unchosen)    -- Don't pick it
 487         | otherwise                     -- Pick it
 488         = (pair,rest)
 489         where
 490           (chosen, unchosen) = choose_loop_breaker rest
 491
 492     bad_choice ((bndr, occ_info), rhs)
 493         =    var_rhs rhs                -- Dont pick var RHS
 494           || inlineMe env bndr          -- Dont pick INLINE thing
 495           || one_occ occ_info           -- Dont pick single-occ thing
 496           || not_fun_ty (idType bndr)   -- Dont pick data-ty thing
 497
 498     not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty))
 499                   where
 500                     (_, rho_ty) = splitForAllTy ty
 501
 502         -- A variable RHS
 503     var_rhs (Var v)   = True
 504     var_rhs other_rhs = False
 505
 506         -- One textual occurrence, whether inside lambda or whatever
 507         -- We stick to just FunOccs because if we're not going to be able
 508         -- to inline the thing on this round it might be better to pick
 509         -- this one as the loop breaker.  Real example (the Enum Ordering instance
 510         -- from PrelBase):
 511         --      rec     f = \ x -> case d of (p,q,r) -> p x
 512         --              g = \ x -> case d of (p,q,r) -> q x
 513         --              d = (v, f, g)
 514         --
 515         -- Here, f and g occur just once; but we can't inline them into d.
 516         -- On the other hand we *could* simplify those case expressions if
 517         -- we didn't stupidly choose d as the loop breaker.
 518
 519     one_occ (OneOcc fun_or_arg _ _ _ _) = isFun fun_or_arg
 520     one_occ other_bind                  = False
 521 \end{code}
 522
 523 @occAnalRhs@ deals with the question of bindings where the Id is marked
 524 by an INLINE pragma.  For these we record that anything which occurs
 525 in its RHS occurs many times.  This pessimistically assumes that ths
 526 inlined binder also occurs many times in its scope, but if it doesn't
 527 we'll catch it next time round.  At worst this costs an extra simplifier pass.
 528 ToDo: try using the occurrence info for the inline'd binder.
 529
 530 [March 97] We do the same for atomic RHSs.  Reason: see notes with reOrderRec.
 531
 532 \begin{code}
 533 occAnalRhs :: OccEnv
 534            -> Id -> CoreExpr    -- Binder and rhs
 535            -> (UsageDetails, SimplifiableCoreExpr)
 536
 537 occAnalRhs env id (Var v)
 538   | isCandidate env v
 539   = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
 540
 541   | otherwise
 542   = (emptyDetails, Var v)
 543
 544 occAnalRhs env id rhs
 545   | inlineMe env id
 546   = (mapIdEnv markMany rhs_usage, rhs')
 547
 548   | otherwise
 549   = (rhs_usage, rhs')
 550
 551   where
 552     (rhs_usage, rhs') = occAnal env rhs
 553 \end{code}
 554
 555 Expressions
 556 ~~~~~~~~~~~
 557 \begin{code}
 558 occAnal :: OccEnv
 559         -> CoreExpr
 560         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
 561             SimplifiableCoreExpr)
 562
 563 occAnal env (Var v)
 564   | isCandidate env v
 565   = (unitIdEnv v (funOccurrence 0), Var v)
 566
 567   | otherwise
 568   = (emptyDetails, Var v)
 569
 570 occAnal env (Lit lit)      = (emptyDetails, Lit lit)
 571 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
 572 \end{code}
 573
 574 We regard variables that occur as constructor arguments as "dangerousToDup":
 575
 576 \begin{verbatim}
 577 module A where
 578 f x = let y = expensive x in
 579       let z = (True,y) in
 580       (case z of {(p,q)->q}, case z of {(p,q)->q})
 581 \end{verbatim}
 582
 583 We feel free to duplicate the WHNF (True,y), but that means
 584 that y may be duplicated thereby.
 585
 586 If we aren't careful we duplicate the (expensive x) call!
 587 Constructors are rather like lambdas in this way.
 588
 589 \begin{code}
 590 occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
 591                               Con con args)
 592
 593 occAnal env (SCC cc body)
 594   = (mapIdEnv markInsideSCC usage, SCC cc body')
 595   where
 596     (usage, body') = occAnal env body
 597
 598 occAnal env (Coerce c ty body)
 599   = (usage, Coerce c ty body')
 600   where
 601     (usage, body') = occAnal env body
 602
 603 occAnal env (App fun arg)
 604   = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
 605   where
 606     (fun_usage, fun') = occAnal    env fun
 607     arg_usage         = occAnalArg env arg
 608
 609 -- For value lambdas we do a special hack.  Consider
 610 --      (\x. \y. ...x...)
 611 -- If we did nothing, x is used inside the \y, so would be marked
 612 -- as dangerous to dup.  But in the common case where the abstraction
 613 -- is applied to two arguments this is over-pessimistic.
 614 -- So instead we don't take account of the \y when dealing with x's usage;
 615 -- instead, the simplifier is careful when partially applying lambdas
 616
 617 occAnal env expr@(Lam (ValBinder binder) body)
 618   = (mapIdEnv markDangerousToDup final_usage,
 619      foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
 620   where
 621     (binders,body)                = collectValBinders expr
 622     (body_usage, body')           = occAnal (env `addNewCands` binders) body
 623     (final_usage, tagged_binders) = tagBinders body_usage binders
 624
 625 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 626 occAnal env (Lam (TyBinder tyvar) body)
 627   = case occAnal env body of { (body_usage, body') ->
 628      (mapIdEnv markDangerousToDup body_usage,
 629       Lam (TyBinder tyvar) body') }
 630 --  where
 631 --    (body_usage, body') = occAnal env body
 632
 633 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
 634
 635 occAnal env (Case scrut alts)
 636   = case occAnalAlts env alts of { (alts_usage, alts')   ->
 637      case occAnal env scrut   of { (scrut_usage, scrut') ->
 638        let
 639         det = scrut_usage `combineUsageDetails` alts_usage
 640        in
 641        if isNullIdEnv det then
 642           (det, Case scrut' alts')
 643        else
 644           (det, Case scrut' alts') }}
 645 {-
 646        (scrut_usage `combineUsageDetails` alts_usage,
 647         Case scrut' alts')
 648   where
 649     (scrut_usage, scrut') = occAnal env scrut
 650     (alts_usage, alts')   = occAnalAlts env alts
 651 -}
 652
 653 occAnal env (Let bind body)
 654   = case occAnal new_env body            of { (body_usage, body') ->
 655     case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
 656        (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
 657   where
 658     new_env                  = env `addNewCands` (bindersOf bind)
 659 --    (body_usage, body')      = occAnal new_env body
 660 --    (final_usage, new_binds) = occAnalBind env bind body_usage
 661 \end{code}
 662
 663 Case alternatives
 664 ~~~~~~~~~~~~~~~~~
 665 \begin{code}
 666 occAnalAlts env (AlgAlts alts deflt)
 667   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 668         -- Note: combine*Alts*UsageDetails...
 669      AlgAlts alts' deflt')
 670   where
 671     (alts_usage,  alts')  = unzip (map do_alt alts)
 672     (deflt_usage, deflt') = occAnalDeflt env deflt
 673
 674     do_alt (con, args, rhs)
 675       = (final_usage, (con, tagged_args, rhs'))
 676       where
 677         new_env            = env `addNewCands` args
 678         (rhs_usage, rhs')          = occAnal new_env rhs
 679         (final_usage, tagged_args) = tagBinders rhs_usage args
 680
 681 occAnalAlts env (PrimAlts alts deflt)
 682   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 683         -- Note: combine*Alts*UsageDetails...
 684      PrimAlts alts' deflt')
 685   where
 686     (alts_usage, alts')   = unzip (map do_alt alts)
 687     (deflt_usage, deflt') = occAnalDeflt env deflt
 688
 689     do_alt (lit, rhs)
 690       = (rhs_usage, (lit, rhs'))
 691       where
 692         (rhs_usage, rhs') = occAnal env rhs
 693
 694 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
 695
 696 occAnalDeflt env (BindDefault binder rhs)
 697   = (final_usage, BindDefault tagged_binder rhs')
 698   where
 699     new_env                      = env `addNewCand` binder
 700     (rhs_usage, rhs')            = occAnal new_env rhs
 701     (final_usage, tagged_binder) = tagBinder rhs_usage binder
 702 \end{code}
 703
 704
 705 Atoms
 706 ~~~~~
 707 \begin{code}
 708 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
 709
 710 occAnalArgs env atoms
 711   = foldr do_one_atom emptyDetails atoms
 712   where
 713     do_one_atom (VarArg v) usage
 714         | isCandidate env v = addOneOcc usage v (argOccurrence 0)
 715         | otherwise         = usage
 716     do_one_atom other_arg  usage = usage
 717
 718
 719 occAnalArg  :: OccEnv -> CoreArg -> UsageDetails
 720
 721 occAnalArg env (VarArg v)
 722   | isCandidate env v = unitDetails v (argOccurrence 0)
 723   | otherwise         = emptyDetails
 724 occAnalArg _   _      = emptyDetails
 725 \end{code}