ghc/compiler/simplCore/OccurAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[OccurAnal]{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 for
  60 type-lambdas too, which effectively prevents such substitutions.  I don't *think*
  61 it disables any interesting ones either.
  62
  63 \begin{code}
  64 #include "HsVersions.h"
  65
  66 module OccurAnal (
  67         occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
  68
  69         -- and to make the interface self-sufficient...
  70         CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
  71         PlainCoreProgram(..), PlainCoreExpr(..),
  72         SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
  73     ) where
  74
  75 IMPORT_Trace
  76 import Outputable       -- ToDo: rm; debugging
  77 import Pretty
  78
  79 import PlainCore        -- the stuff we read...
  80 import TaggedCore       -- ... and produce Simplifiable*
  81
  82 import AbsUniType
  83 import BinderInfo
  84 import CmdLineOpts      ( GlobalSwitch(..), SimplifierSwitch(..) )
  85 import Digraph          ( stronglyConnComp )
  86 import Id               ( eqId, idWantsToBeINLINEd, isConstMethodId_maybe,
  87                           isSpecPragmaId_maybe, SpecInfo )
  88 import IdEnv
  89 import Maybes
  90 import UniqSet
  91 import Util
  92 \end{code}
  93
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection[OccurAnal-types]{Data types}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101 \begin{code}
 102 data OccEnv = OccEnv
 103                 Bool            -- Keep-unused-bindings flag
 104                                 -- False <=> OK to chuck away binding
 105                                 --           and ignore occurrences within it
 106                 Bool            -- Keep-spec-pragma-ids flag
 107                                 -- False <=> OK to chuck away spec pragma bindings
 108                                 --           and ignore occurrences within it
 109                 Bool            -- Keep-conjurable flag
 110                                 -- False <=> OK to throw away *dead*
 111                                 -- "conjurable" Ids; at the moment, that
 112                                 -- *only* means constant methods, which
 113                                 -- are top-level.  A use of a "conjurable"
 114                                 -- Id may appear out of thin air -- e.g.,
 115                                 -- specialiser conjuring up refs to const
 116                                 -- methods.
 117                 Bool            -- IgnoreINLINEPragma flag
 118                                 -- False <=> OK to use INLINEPragma information
 119                                 -- True  <=> ignore INLINEPragma information
 120                 (UniqSet Id)    -- Candidates
 121
 122 addNewCands :: OccEnv -> [Id] -> OccEnv
 123 addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
 124   = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
 125
 126 addNewCand :: OccEnv -> Id -> OccEnv
 127 addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
 128   = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
 129
 130 isCandidate :: OccEnv -> Id -> Bool
 131 isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
 132
 133 ignoreINLINEPragma :: OccEnv -> Bool
 134 ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
 135
 136 keepUnusedBinding :: OccEnv -> Id -> Bool
 137 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
 138   = keep_dead || (keep_spec && is_spec)
 139   where
 140     is_spec = maybeToBool (isSpecPragmaId_maybe binder)
 141
 142 keepBecauseConjurable :: OccEnv -> Id -> Bool
 143 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
 144   = keep_conjurable && is_conjurable
 145   where
 146     is_conjurable = maybeToBool (isConstMethodId_maybe binder)
 147
 148 type UsageDetails = IdEnv BinderInfo    -- A finite map from ids to their usage
 149
 150 combineUsageDetails, combineAltsUsageDetails
 151         :: UsageDetails -> UsageDetails -> UsageDetails
 152
 153 combineUsageDetails usage1 usage2
 154   = --BSCC("combineUsages")
 155     combineIdEnvs combineBinderInfo usage1 usage2
 156     --ESCC
 157
 158 combineAltsUsageDetails usage1 usage2
 159   = --BSCC("combineUsages")
 160     combineIdEnvs combineAltsBinderInfo usage1 usage2
 161     --ESCC
 162
 163 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
 164 addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
 165         -- ToDo: make this more efficient
 166
 167 emptyDetails = (nullIdEnv :: UsageDetails)
 168
 169 unitDetails id info = (unitIdEnv id info :: UsageDetails)
 170
 171 tagBinders :: UsageDetails              -- Of scope
 172            -> [Id]                      -- Binders
 173            -> (UsageDetails,            -- Details with binders removed
 174               [(Id,BinderInfo)])        -- Tagged binders
 175
 176 tagBinders usage binders
 177   = (usage `delManyFromIdEnv` binders,
 178      [(binder, usage_of usage binder) | binder <- binders]
 179     )
 180
 181 tagBinder :: UsageDetails               -- Of scope
 182           -> Id                         -- Binders
 183           -> (UsageDetails,             -- Details with binders removed
 184               (Id,BinderInfo))          -- Tagged binders
 185
 186 tagBinder usage binder
 187   = (usage `delOneFromIdEnv` binder,
 188      (binder, usage_of usage binder)
 189     )
 190
 191 usage_of usage binder
 192   | isExported binder = ManyOcc 0 -- Exported things count as many
 193   | otherwise
 194   = case lookupIdEnv usage binder of
 195       Nothing   -> DeadCode
 196       Just info -> info
 197
 198 isNeeded env usage binder
 199   = case usage_of usage binder of
 200       DeadCode  -> keepUnusedBinding env binder -- Maybe keep it anyway
 201       other     -> True
 202 \end{code}
 203
 204
 205 %************************************************************************
 206 %*                                                                      *
 207 \subsection[OccurAnal-main]{Counting occurrences: main function}
 208 %*                                                                      *
 209 %************************************************************************
 210
 211 Here's the externally-callable interface:
 212
 213 \begin{code}
 214 occurAnalyseBinds
 215         :: [PlainCoreBinding]           -- input
 216         -> (GlobalSwitch -> Bool)
 217         -> (SimplifierSwitch -> Bool)
 218         -> [SimplifiableCoreBinding]    -- output
 219
 220 occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
 221   | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
 222   | otherwise                        = binds'
 223   where
 224     (_, binds') = do initial_env binds
 225
 226     initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
 227                          (simplifier_sw_chkr KeepSpecPragmaIds)
 228                          (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
 229                          (simplifier_sw_chkr IgnoreINLINEPragma)
 230                          emptyUniqSet
 231
 232     do env [] = (emptyDetails, [])
 233     do env (bind:binds)
 234       = (final_usage, new_binds ++ the_rest)
 235       where
 236         new_env                  = env `addNewCands` (bindersOf bind)
 237         (binds_usage, the_rest)  = do new_env binds
 238         (final_usage, new_binds) = --BSCC("occAnalBind1")
 239                                    occAnalBind env bind binds_usage
 240                                    --ESCC
 241 \end{code}
 242
 243 \begin{code}
 244 occurAnalyseExpr :: UniqSet Id                  -- Set of interesting free vars
 245                  -> PlainCoreExpr
 246                  -> (IdEnv BinderInfo,          -- Occ info for interesting free vars
 247                      SimplifiableCoreExpr)
 248
 249 occurAnalyseExpr candidates expr
 250   = occAnal initial_env expr
 251   where
 252     initial_env = OccEnv False {- Drop unused bindings -}
 253                          False {- Drop SpecPragmaId bindings -}
 254                          True  {- Keep conjurable Ids -}
 255                          False {- Do not ignore INLINE Pragma -}
 256                          candidates
 257
 258 occurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
 259 occurAnalyseGlobalExpr expr
 260   =     -- Top level expr, so no interesting free vars, and
 261         -- discard occurence info returned
 262     expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr
 263 \end{code}
 264
 265 %************************************************************************
 266 %*                                                                      *
 267 \subsection[OccurAnal-main]{Counting occurrences: main function}
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 Bindings
 272 ~~~~~~~~
 273
 274 \begin{code}
 275 occAnalBind :: OccEnv
 276             -> PlainCoreBinding
 277             -> UsageDetails             -- Usage details of scope
 278             -> (UsageDetails,           -- Of the whole let(rec)
 279                 [SimplifiableCoreBinding])
 280
 281 occAnalBind env (CoNonRec binder rhs) body_usage
 282   | isNeeded env body_usage binder              -- It's mentioned in body
 283   = (final_body_usage `combineUsageDetails` rhs_usage,
 284      [CoNonRec tagged_binder rhs'])
 285
 286   | otherwise
 287   = (body_usage, [])
 288
 289   where
 290     (rhs_usage, rhs')                 = occAnalRhs env binder rhs
 291     (final_body_usage, tagged_binder) = tagBinder body_usage binder
 292 \end{code}
 293
 294 Dropping dead code for recursive bindings is done in a very simple way:
 295
 296         the entire set of bindings is dropped if none of its binders are
 297         mentioned in its body; otherwise none are.
 298
 299 This seems to miss an obvious improvement.
 300 @
 301         letrec  f = ...g...
 302                 g = ...f...
 303         in
 304         ...g...
 305
 306 ===>
 307
 308         letrec f = ...g...
 309                g = ...(...g...)...
 310         in
 311         ...g...
 312 @
 313
 314 Now @f@ is unused. But dependency analysis will sort this out into a
 315 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
 316 It isn't easy to do a perfect job in one blow.  Consider
 317
 318 @
 319         letrec f = ...g...
 320                g = ...h...
 321                h = ...k...
 322                k = ...m...
 323                m = ...m...
 324         in
 325         ...m...
 326 @
 327
 328
 329 \begin{code}
 330 occAnalBind env (CoRec pairs) body_usage
 331   = foldr do_final_bind (body_usage, []) sccs
 332   where
 333
 334     (binders, rhss) = unzip pairs
 335     new_env         = env `addNewCands` binders
 336
 337     analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
 338     analysed_pairs  = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
 339
 340     lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
 341     lookup id =  assoc "occAnalBind:lookup" analysed_pairs id
 342
 343
 344     ---- stuff for dependency analysis of binds -------------------------------
 345
 346     edges :: [(Id,Id)]          -- (a,b) means a mentions b
 347     edges = concat [ edges_from binder rhs_usage
 348                    | (binder, (rhs_usage, _)) <- analysed_pairs]
 349
 350     edges_from :: Id -> UsageDetails -> [(Id,Id)]
 351     edges_from id its_rhs_usage
 352       = [(id,mentioned) | mentioned <- binders,
 353                           maybeToBool (lookupIdEnv its_rhs_usage mentioned)
 354         ]
 355
 356     sccs :: [[Id]]
 357     sccs = case binders of
 358                 [_]   -> [binders]      -- Singleton; no need to analyse
 359                 other -> stronglyConnComp eqId edges binders
 360
 361     ---- stuff to "re-constitute" bindings from dependency-analysis info ------
 362
 363     do_final_bind sCC@[binder] (body_usage, binds_so_far)
 364       | isNeeded env body_usage binder
 365       = (combined_usage, new_bind:binds_so_far)
 366
 367       | otherwise               -- Dead
 368       = (body_usage, binds_so_far)
 369       where
 370         total_usage                     = combineUsageDetails body_usage rhs_usage
 371         (rhs_usage, rhs')               = lookup binder
 372         (combined_usage, tagged_binder) = tagBinder total_usage binder
 373
 374         new_bind
 375           | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
 376           | otherwise                        = CoNonRec tagged_binder rhs'
 377           where
 378             mentions_itself binder usage
 379               = maybeToBool (lookupIdEnv usage binder)
 380
 381     do_final_bind sCC (body_usage, binds_so_far)
 382       | any (isNeeded env body_usage) sCC
 383       = (combined_usage, new_bind:binds_so_far)
 384
 385       | otherwise               -- Dead
 386       = (body_usage, binds_so_far)
 387       where
 388         (rhs_usages, rhss')              = unzip (map lookup sCC)
 389         total_usage                      = foldr combineUsageDetails body_usage rhs_usages
 390         (combined_usage, tagged_binders) = tagBinders total_usage sCC
 391
 392         new_bind                         = CoRec (tagged_binders `zip` rhss')
 393 \end{code}
 394
 395 @occAnalRhs@ deals with the question of bindings where the Id is marked
 396 by an INLINE pragma.  For these we record that anything which occurs
 397 in its RHS occurs many times.  This pessimistically assumes that ths
 398 inlined binder also occurs many times in its scope, but if it doesn't
 399 we'll catch it next time round.  At worst this costs an extra simplifier pass.
 400 ToDo: try using the occurrence info for the inline'd binder.
 401
 402 \begin{code}
 403 occAnalRhs :: OccEnv
 404            -> Id                -- Binder
 405            -> PlainCoreExpr     -- Rhs
 406            -> (UsageDetails, SimplifiableCoreExpr)
 407
 408 occAnalRhs env id rhs
 409   | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
 410   = (mapIdEnv markMany rhs_usage, rhs')
 411
 412   | otherwise
 413   = (rhs_usage, rhs')
 414
 415   where
 416     (rhs_usage, rhs') = occAnal env rhs
 417 \end{code}
 418
 419 Expressions
 420 ~~~~~~~~~~~
 421 \begin{code}
 422 occAnal :: OccEnv
 423         -> PlainCoreExpr
 424         -> (UsageDetails,               -- Gives info only about the "interesting" Ids
 425             SimplifiableCoreExpr)
 426
 427 occAnal env (CoVar v)
 428   | isCandidate env v
 429   = (unitIdEnv v (funOccurrence 0), CoVar v)
 430
 431   | otherwise
 432   = (emptyDetails, CoVar v)
 433
 434 occAnal env (CoLit lit)    = (emptyDetails, CoLit lit)
 435 occAnal env (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
 436 occAnal env (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
 437
 438 occAnal env (CoSCC cc body)
 439   = (mapIdEnv markInsideSCC usage, CoSCC cc body')
 440   where
 441     (usage, body') = occAnal env body
 442
 443 occAnal env (CoApp fun arg)
 444   = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
 445   where
 446     (fun_usage, fun') = occAnal env fun
 447     arg_usage         = occAnalAtom env arg
 448
 449 occAnal env (CoTyApp fun ty)
 450   = (fun_usage, CoTyApp fun' ty)
 451   where
 452     (fun_usage, fun') = occAnal env fun
 453
 454 occAnal env (CoLam binders body)
 455   = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
 456   where
 457     new_env                       = env `addNewCands` binders
 458     (body_usage, body')           = occAnal new_env body
 459     (final_usage, tagged_binders) = tagBinders body_usage binders
 460
 461 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 462 occAnal env (CoTyLam tyvar body)
 463   = (mapIdEnv markDangerousToDup body_usage, CoTyLam tyvar body')
 464   where
 465     (body_usage, body') = occAnal env body
 466
 467 occAnal env (CoCase scrut alts)
 468   = (scrut_usage `combineUsageDetails` alts_usage,
 469      CoCase scrut' alts')
 470   where
 471     (scrut_usage, scrut') = occAnal env scrut
 472     (alts_usage, alts')   = occAnalAlts env alts
 473
 474 occAnal env (CoLet bind body)
 475   = (final_usage, foldr CoLet body' new_binds) -- mkCoLet* wants PlainCore... (sigh)
 476   where
 477     new_env                  = env `addNewCands` (bindersOf bind)
 478     (body_usage, body')      = occAnal new_env body
 479     (final_usage, new_binds) = --BSCC("occAnalBind2")
 480                                occAnalBind env bind body_usage
 481                                --ESCC
 482 \end{code}
 483
 484 Case alternatives
 485 ~~~~~~~~~~~~~~~~~
 486 \begin{code}
 487 occAnalAlts env (CoAlgAlts alts deflt)
 488   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 489         -- Note: combine*Alts*UsageDetails...
 490      CoAlgAlts alts' deflt')
 491   where
 492     (alts_usage,  alts')  = unzip (map do_alt alts)
 493     (deflt_usage, deflt') = occAnalDeflt env deflt
 494
 495     do_alt (con, args, rhs)
 496       = (final_usage, (con, tagged_args, rhs'))
 497       where
 498         new_env            = env `addNewCands` args
 499         (rhs_usage, rhs')          = occAnal new_env rhs
 500         (final_usage, tagged_args) = tagBinders rhs_usage args
 501
 502 occAnalAlts env (CoPrimAlts alts deflt)
 503   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 504         -- Note: combine*Alts*UsageDetails...
 505      CoPrimAlts alts' deflt')
 506   where
 507     (alts_usage, alts')   = unzip (map do_alt alts)
 508     (deflt_usage, deflt') = occAnalDeflt env deflt
 509
 510     do_alt (lit, rhs)
 511       = (rhs_usage, (lit, rhs'))
 512       where
 513         (rhs_usage, rhs') = occAnal env rhs
 514
 515 occAnalDeflt env CoNoDefault = (emptyDetails, CoNoDefault)
 516
 517 occAnalDeflt env (CoBindDefault binder rhs)
 518   = (final_usage, CoBindDefault tagged_binder rhs')
 519   where
 520     new_env                      = env `addNewCand` binder
 521     (rhs_usage, rhs')            = occAnal new_env rhs
 522     (final_usage, tagged_binder) = tagBinder rhs_usage binder
 523 \end{code}
 524
 525
 526 Atoms
 527 ~~~~~
 528 \begin{code}
 529 occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
 530
 531 occAnalAtoms env atoms
 532   = foldr do_one_atom emptyDetails atoms
 533   where
 534     do_one_atom (CoLitAtom lit) usage = usage
 535     do_one_atom (CoVarAtom v) usage
 536         | isCandidate env v = addOneOcc usage v (argOccurrence 0)
 537         | otherwise         = usage
 538
 539
 540 occAnalAtom  :: OccEnv -> PlainCoreAtom -> UsageDetails
 541
 542 occAnalAtom env (CoLitAtom lit) = emptyDetails
 543 occAnalAtom env (CoVarAtom v)
 544   | isCandidate env v = unitDetails v (argOccurrence 0)
 545   | otherwise         = emptyDetails
 546 \end{code}