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