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