ghc/compiler/simplCore/NewOccurAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[NewOccurAnal]{The *New* Occurrence analysis pass}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 The occurrence analyser analyses the way in which variables are used
  11 in their scope, and pins that information on the binder.  It does {\em
  12 not} take any strategic decisions about what to do as a result (eg
  13 discard binding, inline binding etc).  That's the job of the
  14 simplifier.
  15
  16 The occurrence analyser {\em simply} records usage information.  That is,
  17 it pins on each binder info on how that binder occurs in its scope.
  18
  19 Any uses within the RHS of a let(rec) binding for a variable which is
  20 itself unused are ignored.  For example:
  21 @
  22         let x = ...
  23             y = ...x...
  24         in
  25         x+1
  26 @
  27 Here, y is unused, so x will be marked as appearing just once.
  28
  29 An exported Id gets tagged as ManyOcc.
  30
  31 IT MUST OBSERVE SCOPING: CANNOT assume unique binders.
  32
  33 Lambdas
  34 ~~~~~~~
  35 The occurrence analyser marks each binder in a lambda the same way.
  36 Thus:
  37         \ x y -> f y x
  38 will have both x and y marked as single occurrence, and *not* dangerous-to-dup.
  39 Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup,
  40 but the simplifer very carefully takes care of this special case.
  41 (See the CoLam case in simplExpr.)
  42
  43 Why?  Because typically applications are saturated, in which case x is *not*
  44 dangerous-to-dup.
  45
  46 Things to muse upon
  47 ~~~~~~~~~~~~~~~~~~~
  48
  49 There *is* a reason not to substitute for
  50 variables applied to types: it can undo the effect of floating
  51 Consider:
  52 \begin{verbatim}
  53         c = /\a -> e
  54         f = /\b -> let d = c b
  55                    in \ x::b -> ...
  56 \end{verbatim}
  57 Here, inlining c would be a Bad Idea.
  58
  59 At present I've set it up so that the "inside-lambda" flag sets set On
  60 for type-lambdas too, which effectively prevents such substitutions.
  61 I don't *think* it disables any interesting ones either.
  62
  63 Oh yes it does.
  64 Consider
  65
  66          let { (u6.sAMi, <1,0>) = (_build s141374) ua.sALY } in
  67          let {
  68            (ua.sAMj, <1,0>) =
  69                /\ s141380 -> \ (u5.sAM1, <2,0>)  (u6.sAMl, <2,0>) ->
  70                    let {
  71                      (u9.sAM7, <2,0>) =
  72                          \ (u7.sAM2, <3,0>) ->
  73                              let { (u8.sAM3, <3,0>) = f.sALV u7.sAM2
  74                              } in  u5.sAM1 u8.sAM3
  75                    } in  ((foldr s141374) s141380) u9.sAM7 u6.sAMl u6.sAMi
  76          } in  (_build s141376) ua.sAMj]
  77
  78 I want to `inline' u6.sAMi, via the foldr/build rule,
  79 but I cant. So I need to inline through /\. I only do it when
  80 I've got a `linear' stack, ie actually real arguments still to apply.
  81
  82 \begin{code}
  83 #include "HsVersions.h"
  84
  85 module NewOccurAnal (
  86         newOccurAnalyseBinds, newOccurAnalyseExpr,
  87
  88         -- and to make the interface self-sufficient...
  89         CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
  90         PlainCoreProgram(..), PlainCoreExpr(..),
  91         SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
  92     ) where
  93
  94 IMPORT_Trace
  95 import Outputable       -- ToDo: rm; debugging
  96 import Pretty
  97
  98 import PlainCore        -- the stuff we read...
  99 import TaggedCore       -- ... and produce Simplifiable*
 100
 101 import AbsUniType
 102 import BinderInfo
 103 import CmdLineOpts      ( GlobalSwitch(..), SimplifierSwitch(..) )
 104 import Digraph          ( stronglyConnComp )
 105 import Id               ( eqId, idWantsToBeINLINEd, isConstMethodId_maybe,
 106                           isSpecPragmaId_maybe, getIdArgUsageInfo,
 107                           SpecInfo
 108                         )
 109 import IdInfo           -- ( ArgUsage(..), ArgUsageInfo, OptIdInfo(..), getArgUsage)
 110 import IdEnv
 111 import Maybes
 112 import UniqSet
 113 import Util
 114 \end{code}
 115
 116
 117 %************************************************************************
 118 %*                                                                      *
 119 \subsection[OccurAnal-types]{Data types}
 120 %*                                                                      *
 121 %************************************************************************
 122
 123 \begin{code}
 124 data OccEnv = OccEnv
 125                 Bool            -- Keep-unused-bindings flag
 126                                 -- False <=> OK to chuck away binding
 127                                 --           and ignore occurrences within it
 128                 Bool            -- Keep-spec-pragma-ids flag
 129                                 -- False <=> OK to chuck away spec pragma bindings
 130                                 --           and ignore occurrences within it
 131                 Bool            -- Keep-conjurable flag
 132                                 -- False <=> OK to throw away *dead*
 133                                 -- "conjurable" Ids; at the moment, that
 134                                 -- *only* means constant methods, which
 135                                 -- are top-level.  A use of a "conjurable"
 136                                 -- Id may appear out of thin air -- e.g.,
 137                                 -- specialiser conjuring up refs to const
 138                                 -- methods.
 139                 Bool            -- IgnoreINLINEPragma flag
 140                                 -- False <=> OK to use INLINEPragma information
 141                                 -- True  <=> ignore INLINEPragma information
 142                 (UniqSet Id)    -- Candidates
 143
 144 addNewCands :: OccEnv -> [Id] -> OccEnv
 145 addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
 146   = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
 147
 148 addNewCand :: OccEnv -> Id -> OccEnv
 149 addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
 150   = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
 151
 152 isCandidate :: OccEnv -> Id -> Bool
 153 isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
 154
 155 ignoreINLINEPragma :: OccEnv -> Bool
 156 ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
 157
 158 keepUnusedBinding :: OccEnv -> Id -> Bool
 159 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
 160   = keep_dead || (keep_spec && is_spec)
 161   where
 162     is_spec = maybeToBool (isSpecPragmaId_maybe binder)
 163
 164 keepBecauseConjurable :: OccEnv -> Id -> Bool
 165 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
 166   = keep_conjurable && is_conjurable
 167   where
 168     is_conjurable = maybeToBool (isConstMethodId_maybe binder)
 169
 170 type UsageDetails = IdEnv BinderInfo    -- A finite map from ids to their usage
 171
 172 combineUsageDetails, combineAltsUsageDetails
 173         :: UsageDetails -> UsageDetails -> UsageDetails
 174
 175 combineUsageDetails usage1 usage2
 176   = --BSCC("combineUsages")
 177     combineIdEnvs combineBinderInfo usage1 usage2
 178     --ESCC
 179
 180 combineAltsUsageDetails usage1 usage2
 181   = --BSCC("combineUsages")
 182     combineIdEnvs combineAltsBinderInfo usage1 usage2
 183     --ESCC
 184
 185 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
 186 addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
 187         -- ToDo: make this more efficient
 188
 189 emptyDetails = (nullIdEnv :: UsageDetails)
 190
 191 unitDetails id info = (unitIdEnv id info :: UsageDetails)
 192
 193 tagBinders :: UsageDetails              -- Of scope
 194            -> [Id]                      -- Binders
 195            -> (UsageDetails,            -- Details with binders removed
 196               [(Id,BinderInfo)])        -- Tagged binders
 197
 198 tagBinders usage binders
 199   = (usage `delManyFromIdEnv` binders,
 200      [(binder, usage_of usage binder) | binder <- binders]
 201     )
 202
 203 tagBinder :: UsageDetails               -- Of scope
 204           -> Id                         -- Binders
 205           -> (UsageDetails,             -- Details with binders removed
 206               (Id,BinderInfo))          -- Tagged binders
 207
 208 tagBinder usage binder
 209   = (usage `delOneFromIdEnv` binder,
 210      (binder, usage_of usage binder)
 211     )
 212
 213 usage_of usage binder
 214   | isExported binder = ManyOcc 0 -- Exported things count as many
 215   | otherwise
 216   = case lookupIdEnv usage binder of
 217       Nothing   -> DeadCode
 218       Just info -> info
 219
 220 fixStkToZero :: Id -> UsageDetails -> UsageDetails
 221 fixStkToZero id env = modifyIdEnv env setBinderInfoArityToZero id
 222
 223 isNeeded env usage binder
 224   = case usage_of usage binder of
 225       DeadCode  -> keepUnusedBinding env binder -- Maybe keep it anyway
 226       other     -> True
 227 \end{code}
 228
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 \subsection[OccurAnal-main]{Counting occurrences: main function}
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 Here's the externally-callable interface:
 237
 238 \begin{code}
 239 newOccurAnalyseBinds
 240         :: [PlainCoreBinding]           -- input
 241         -> (GlobalSwitch -> Bool)
 242         -> (SimplifierSwitch -> Bool)
 243         -> [SimplifiableCoreBinding]    -- output
 244
 245 newOccurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
 246   | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
 247   | otherwise                        = binds'
 248   where
 249     (_, binds') = do initial_env binds
 250
 251     initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
 252                          (simplifier_sw_chkr KeepSpecPragmaIds)
 253                          (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
 254                          (simplifier_sw_chkr IgnoreINLINEPragma)
 255                          emptyUniqSet
 256
 257     do env [] = (emptyDetails, [])
 258     do env (bind:binds)
 259       = (final_usage, new_binds ++ the_rest)
 260       where
 261         new_env                  = env `addNewCands` (bindersOf bind)
 262         (binds_usage, the_rest)  = do new_env binds
 263         (final_usage, new_binds) = --BSCC("occAnalBind1")
 264                                    occAnalBind env bind binds_usage
 265                                    --ESCC
 266 \end{code}
 267
 268 \begin{code}
 269 newOccurAnalyseExpr :: UniqSet Id                       -- Set of interesting free vars
 270                  -> PlainCoreExpr
 271                  -> (IdEnv BinderInfo,          -- Occ info for interesting free vars
 272                      SimplifiableCoreExpr)
 273
 274 newOccurAnalyseExpr candidates expr
 275   = occAnal initial_env initContext expr
 276   where
 277     initial_env = OccEnv False {- Drop unused bindings -}
 278                          False {- Drop SpecPragmaId bindings -}
 279                          True  {- Keep conjurable Ids -}
 280                          False {- Do not ignore INLINE Pragma -}
 281                          candidates
 282
 283 newOccurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
 284 newOccurAnalyseGlobalExpr expr
 285   =     -- Top level expr, so no interesting free vars, and
 286         -- discard occurence info returned
 287     expr' where (_, expr') = newOccurAnalyseExpr emptyUniqSet expr
 288 \end{code}
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection[OccurAnal-main]{Counting occurrences: main function}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 Bindings
 297 ~~~~~~~~
 298
 299 \begin{code}
 300 occAnalBind :: OccEnv
 301             -> PlainCoreBinding
 302             -> UsageDetails             -- Usage details of scope
 303             -> (UsageDetails,           -- Of the whole let(rec)
 304                 [SimplifiableCoreBinding])
 305
 306 occAnalBind env (CoNonRec binder rhs) body_usage
 307   | isNeeded env body_usage binder              -- It's mentioned in body
 308   = (final_body_usage `combineUsageDetails` rhs_usage,
 309      [CoNonRec tagged_binder rhs'])
 310
 311   | otherwise
 312   = (body_usage, [])
 313
 314   where
 315     stk = mkContextFromBinderInfo (usage_of body_usage binder)
 316     (rhs_usage, rhs')                 = occAnalRhs env binder stk rhs
 317     (final_body_usage, tagged_binder) = tagBinder body_usage binder
 318
 319 occAnalBind env (CoRec [(binder,rhs)]) body_usage
 320   | getContextSize after_stk < getContextSize stk && mentions_itself
 321                                 -- our pre-condition does not hold!
 322                                 -- so, we have to go back, and
 323                                 -- *make* of pre-condition hold.
 324         -- Will, you can leave out this trace
 325   = {-pprTrace ("after_stk < stk (BAD, BAD, VERY VERY BAD):"
 326         ++ show (getContextSize after_stk,getContextSize stk)) (ppr PprDebug binder) -}
 327     (occAnalBind env (CoRec [(binder,rhs)]) (fixStkToZero binder body_usage))
 328
 329   | isNeeded env body_usage binder              -- It's mentioned in body
 330   = --BSCC("occAnalBindC")
 331     (final_usage, [final_bind])
 332     --ESCC
 333
 334   | otherwise
 335   = --BSCC("occAnalBindD")
 336     (body_usage, [])
 337     --ESCC
 338
 339   where
 340     stk = shareContext (mkContextFromBinderInfo (usage_of body_usage binder))
 341     new_env                      = env `addNewCand` binder
 342     (rhs_usage, rhs')            = occAnalRhs new_env binder stk rhs
 343     total_usage                  = combineUsageDetails body_usage rhs_usage
 344     (final_usage, tagged_binder) = tagBinder total_usage binder
 345
 346     after_stk = mkContextFromBinderInfo (usage_of rhs_usage binder)
 347
 348     final_bind = if mentions_itself
 349                  then CoRec    [(tagged_binder,rhs')]
 350                  else CoNonRec tagged_binder rhs'
 351
 352     mentions_itself = maybeToBool (lookupIdEnv rhs_usage binder)
 353 \end{code}
 354
 355 Dropping dead code for recursive bindings is done in a very simple way:
 356
 357         the entire set of bindings is dropped if none of its binders are
 358         mentioned in its body; otherwise none are.
 359
 360 This seems to miss an obvious improvement.
 361 @
 362         letrec  f = ...g...
 363                 g = ...f...
 364         in
 365         ...g...
 366
 367 ===>
 368
 369         letrec f = ...g...
 370                g = ...(...g...)...
 371         in
 372         ...g...
 373 @
 374
 375 Now @f@ is unused. But dependency analysis will sort this out into a
 376 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
 377 It isn't easy to do a perfect job in one blow.  Consider
 378
 379 @
 380         letrec f = ...g...
 381                g = ...h...
 382                h = ...k...
 383                k = ...m...
 384                m = ...m...
 385         in
 386         ...m...
 387 @
 388
 389
 390 \begin{code}
 391 occAnalBind env (CoRec pairs) body_usage
 392   = foldr do_final_bind (body_usage, []) sccs
 393   where
 394
 395     (binders, rhss) = unzip pairs
 396     new_env         = env `addNewCands` binders
 397
 398     analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
 399     analysed_pairs  = [(id, occAnalRhs new_env id initContext rhs) | (id,rhs) <- pairs]
 400
 401     lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
 402     lookup id =  assoc "occAnalBind:lookup" analysed_pairs id
 403
 404
 405     ---- stuff for dependency analysis of binds -------------------------------
 406
 407     edges :: [(Id,Id)]          -- (a,b) means a mentions b
 408     edges = concat [ edges_from binder rhs_usage
 409                    | (binder, (rhs_usage, _)) <- analysed_pairs]
 410
 411     edges_from :: Id -> UsageDetails -> [(Id,Id)]
 412     edges_from id its_rhs_usage
 413       = [(id,mentioned) | mentioned <- binders,
 414                           maybeToBool (lookupIdEnv its_rhs_usage mentioned)
 415         ]
 416
 417     sccs :: [[Id]]
 418     sccs = case binders of
 419                 [_]   -> [binders]      -- Singleton; no need to analyse
 420                 other -> stronglyConnComp eqId edges binders
 421
 422     ---- stuff to "re-constitute" bindings from dependency-analysis info ------
 423
 424     do_final_bind sCC@[binder] (body_usage, binds_so_far)
 425       | isNeeded env body_usage binder
 426       = (combined_usage, new_bind:binds_so_far)
 427
 428       | otherwise               -- Dead
 429       = (body_usage, binds_so_far)
 430       where
 431         total_usage                     = combineUsageDetails body_usage rhs_usage
 432         (rhs_usage, rhs')               = lookup binder
 433         (combined_usage, tagged_binder) = tagBinder total_usage binder
 434
 435         new_bind
 436           | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
 437           | otherwise                        = CoNonRec tagged_binder rhs'
 438           where
 439             mentions_itself binder usage
 440               = maybeToBool (lookupIdEnv usage binder)
 441
 442     do_final_bind sCC (body_usage, binds_so_far)
 443       | any (isNeeded env body_usage) sCC
 444       = (combined_usage, new_bind:binds_so_far)
 445
 446       | otherwise               -- Dead
 447       = (body_usage, binds_so_far)
 448       where
 449         (rhs_usages, rhss')              = unzip (map lookup sCC)
 450         total_usage                      = foldr combineUsageDetails body_usage rhs_usages
 451         (combined_usage, tagged_binders) = tagBinders total_usage sCC
 452
 453         new_bind                         = CoRec (tagged_binders `zip` rhss')
 454 \end{code}
 455
 456 @occAnalRhs@ deals with the question of bindings where the Id is marked
 457 by an INLINE pragma.  For these we record that anything which occurs
 458 in its RHS occurs many times.  This pessimistically assumes that ths
 459 inlined binder also occurs many times in its scope, but if it doesn't
 460 we'll catch it next time round.  At worst this costs an extra simplifier pass.
 461 ToDo: try using the occurrence info for the inline'd binder.
 462
 463 \begin{code}
 464 occAnalRhs :: OccEnv
 465            -> Id                -- Binder
 466            -> Context           -- Stack Style Context
 467            -> PlainCoreExpr     -- Rhs
 468            -> (UsageDetails, SimplifiableCoreExpr)
 469
 470 occAnalRhs env id stk rhs
 471   | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
 472   = (mapIdEnv markMany rhs_usage, rhs')
 473
 474   | otherwise
 475   = (rhs_usage, rhs')
 476
 477   where
 478     (rhs_usage, rhs') = occAnal env stk rhs
 479 \end{code}
 480
 481 Expressions
 482 ~~~~~~~~~~~
 483 \begin{code}
 484 occAnal :: OccEnv
 485         -> Context
 486         -> PlainCoreExpr
 487         -> (UsageDetails,               -- Gives info only about the "interesting" Ids
 488             SimplifiableCoreExpr)
 489
 490 occAnal env stk (CoVar v)
 491   | isCandidate env v
 492   = (unitIdEnv v (funOccurrence (getContextSize stk)), CoVar v)
 493
 494   | otherwise
 495   = (emptyDetails, CoVar v)
 496
 497 occAnal env _ (CoLit lit)          = (emptyDetails, CoLit lit)
 498 -- PERHAPS ASSERT THAT STACK == 0 ?
 499 occAnal env _ (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
 500 occAnal env _ (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
 501
 502 occAnal env stk (CoSCC lbl body)
 503   = (mapIdEnv markInsideSCC usage, CoSCC lbl body')
 504   where
 505     (usage, body') = occAnal env initContext body
 506
 507 occAnal env stk (CoApp fun arg)
 508   = occAnalApp env (incContext stk) [ValArg arg] fun
 509 occAnal env stk (CoTyApp fun arg)
 510   = occAnalApp env stk [TypeArg arg] fun
 511 {-
 512 occAnal env (CoApp fun arg)
 513   = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
 514   where
 515     (fun_usage, fun') = occAnal env fun
 516     arg_usage         = occAnalAtom env arg
 517
 518 occAnal env (CoTyApp fun ty)
 519   = (fun_usage, CoTyApp fun' ty)
 520   where
 521     (fun_usage, fun') = occAnal env fun
 522 -}
 523 occAnal env stk (CoLam binders body) | isLinContext stk
 524   = (final_usage, mkCoLam tagged_binders body')
 525   where
 526     (lin_binders,other_binders)   = splitAt (getContextSize stk) binders
 527     new_env                       = env `addNewCands` lin_binders
 528     (body_usage, body')           = occAnal new_env (lamOnContext stk (length lin_binders))
 529                                                 (mkCoLam other_binders body)
 530     (final_usage, tagged_binders) = tagBinders body_usage lin_binders
 531
 532 occAnal env stk (CoLam binders body)
 533   = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
 534   where
 535     new_env                       = env `addNewCands` binders
 536     (body_usage, body')           = occAnal new_env (lamOnContext stk (length binders)) body
 537     (final_usage, tagged_binders) = tagBinders body_usage binders
 538
 539 {-
 540 occAnal env (CoLam binders body)
 541   = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
 542   where
 543     new_env                       = env `addNewCands` binders
 544     (body_usage, body')           = occAnal new_env body
 545     (final_usage, tagged_binders) = tagBinders body_usage binders
 546 -}
 547
 548 occAnal env stk (CoTyLam tyvar body)
 549   = (new_body_usage, CoTyLam tyvar body')
 550   where
 551     (body_usage, body') = occAnal env stk body
 552     new_body_usage = if isLinContext stk
 553                      then body_usage
 554                      else mapIdEnv markDangerousToDup body_usage
 555
 556 occAnal env stk (CoCase scrut alts)
 557   = (scrut_usage `combineUsageDetails` alts_usage,
 558      CoCase scrut' alts')
 559   where
 560     (scrut_usage, scrut') = occAnal env initContext scrut
 561     (alts_usage, alts')   = occAnalAlts env stk alts
 562
 563
 564 occAnal env stk (CoLet bind body)
 565   = (final_usage  , foldr CoLet body' new_binds) -- mkCoLets* wants PlainCore... (sigh)
 566   where
 567     new_env                  = env `addNewCands` (bindersOf bind)
 568     (body_usage, body')      = occAnal new_env stk {- ?? -} body
 569     (final_usage, new_binds) = --BSCC("occAnalBind2")
 570                                occAnalBind env bind body_usage
 571                                --ESCC
 572 \end{code}
 573
 574 Case alternatives
 575 ~~~~~~~~~~~~~~~~~
 576 \begin{code}
 577 occAnalAlts env stk (CoAlgAlts alts deflt)
 578   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 579         -- Note: combine*Alts*UsageDetails...
 580      CoAlgAlts alts' deflt')
 581   where
 582     (alts_usage,  alts')  = unzip (map do_alt alts)
 583     (deflt_usage, deflt') = occAnalDeflt env stk deflt
 584
 585     do_alt (con, args, rhs)
 586       = (final_usage, (con, tagged_args, rhs'))
 587       where
 588         new_env            = env `addNewCands` args
 589         (rhs_usage, rhs')          = occAnal new_env stk rhs
 590         (final_usage, tagged_args) = tagBinders rhs_usage args
 591
 592 occAnalAlts env stk (CoPrimAlts alts deflt)
 593   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 594         -- Note: combine*Alts*UsageDetails...
 595      CoPrimAlts alts' deflt')
 596   where
 597     (alts_usage, alts')   = unzip (map do_alt alts)
 598     (deflt_usage, deflt') = occAnalDeflt env stk deflt
 599
 600     do_alt (lit, rhs)
 601       = (rhs_usage, (lit, rhs'))
 602       where
 603         (rhs_usage, rhs') = occAnal env stk rhs
 604
 605 occAnalDeflt env stk CoNoDefault = (emptyDetails, CoNoDefault)
 606
 607 occAnalDeflt env stk (CoBindDefault binder rhs)
 608   = (final_usage, CoBindDefault tagged_binder rhs')
 609   where
 610     new_env                      = env `addNewCand` binder
 611     (rhs_usage, rhs')            = occAnal new_env stk rhs
 612     (final_usage, tagged_binder) = tagBinder rhs_usage binder
 613 \end{code}
 614
 615
 616 Atoms
 617 ~~~~~
 618 \begin{code}
 619 occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
 620
 621 occAnalAtoms env atoms
 622   = foldr do_one_atom emptyDetails atoms
 623   where
 624     do_one_atom (CoLitAtom lit) usage = usage
 625     do_one_atom (CoVarAtom v) usage
 626         | isCandidate env v = addOneOcc usage v (argOccurrence 0)
 627         | otherwise         = usage
 628
 629
 630 occAnalArgAtoms :: OccEnv -> [(PlainCoreAtom,ArgUsage)] -> UsageDetails
 631 occAnalArgAtoms env atoms
 632   = foldr do_one_atom emptyDetails atoms
 633   where
 634     do_one_atom (CoLitAtom lit,_) usage = usage
 635     do_one_atom (CoVarAtom v,ArgUsage ar) usage
 636         | isCandidate env v = addOneOcc usage v (argOccurrence ar)
 637         | otherwise         = usage
 638     do_one_atom (CoVarAtom v,UnknownArgUsage) usage
 639         | isCandidate env v = addOneOcc usage v (argOccurrence 0)
 640         | otherwise         = usage
 641
 642 occAnalAtom  :: OccEnv -> PlainCoreAtom -> UsageDetails
 643
 644 occAnalAtom env (CoLitAtom lit) = emptyDetails
 645 occAnalAtom env (CoVarAtom v)
 646   | isCandidate env v = unitDetails v (argOccurrence 0)
 647   | otherwise         = emptyDetails
 648 --
 649 -- This function looks for (fully) applied calls to special ids.
 650 --
 651 occAnalApp
 652         :: OccEnv
 653         -> Context
 654         -> [PlainCoreArg]
 655         -> PlainCoreExpr
 656         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
 657             SimplifiableCoreExpr)
 658 occAnalApp env stk args fun@(CoVar v)
 659   | not (null aut)
 660   && getContextSize stk >= length aut   -- fully applied
 661   = (fun_usage `combineUsageDetails` arg_usages,
 662         applyToArgs fun' args)
 663     where
 664         val_args = [ x | ValArg x <- args ]
 665         aut = getArgUsage (getIdArgUsageInfo v)
 666         (fun_usage, fun') = occAnal env stk fun
 667         arg_usages = occAnalArgAtoms env (zip val_args aut)
 668 occAnalApp env stk args (CoApp fun arg)
 669   = occAnalApp env (incContext stk) (ValArg arg:args) fun
 670 occAnalApp env stk args (CoTyApp fun arg)
 671   = occAnalApp env stk (TypeArg arg:args) fun
 672 occAnalApp env stk args fun
 673   = (fun_usage `combineUsageDetails` arg_usages,
 674         applyToArgs fun' args)
 675     where
 676         (fun_usage, fun') = occAnal env stk fun
 677         arg_usages = occAnalAtoms env val_args
 678         val_args = [ x | ValArg x <- args ]
 679 \end{code}
 680
 681 %************************************************************************
 682 %*                                                                      *
 683 \subsection[OccurAnal-main]{Counting occurrences: main function}
 684 %*                                                                      *
 685 %************************************************************************
 686
 687
 688 Abstract, but simple rep. for stacks.
 689 \begin{code}
 690 data Context = Context Int Bool -- if b then n > 0
 691
 692 lamOnContext :: Context -> Int -> Context
 693 lamOnContext (Context n b) i = mkContext (max 0 (n - i)) b
 694
 695 isLinContext :: Context -> Bool
 696 isLinContext (Context n b) = b
 697
 698 getContextSize :: Context -> Int
 699 getContextSize (Context n b) = n
 700
 701 incContext :: Context -> Context
 702 incContext (Context n u) = Context (n + 1) u
 703
 704 initContext :: Context
 705 initContext = Context 0 False
 706
 707 shareContext :: Context -> Context
 708 shareContext (Context n u) = mkContext n False
 709
 710 mkContext :: Int -> Bool -> Context
 711 mkContext 0 _ = Context 0 False
 712 mkContext i b = Context i b
 713
 714 mkContextFromBinderInfo :: BinderInfo -> Context
 715 mkContextFromBinderInfo (DeadCode)         = mkContext 0 False
 716 mkContextFromBinderInfo (ManyOcc i)        = mkContext i False
 717 mkContextFromBinderInfo bi@(OneOcc _ _ _ _ i)
 718                                            = mkContext i (oneSafeOcc True bi)
 719 \end{code}
 720