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