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 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, 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 combineBinderInfo usage1 usage2
 106
 107 combineAltsUsageDetails usage1 usage2
 108   = combineIdEnvs combineAltsBinderInfo usage1 usage2
 109
 110 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
 111 addOneOcc usage id info
 112   = combineIdEnvs combineBinderInfo 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     expr' where (_, expr') = 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 (tagged_binders `zip` 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 (App fun arg)
 391   = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
 392   where
 393     (fun_usage, fun') = occAnal    env fun
 394     arg_usage         = occAnalArg env arg
 395
 396 occAnal env (Lam (ValBinder binder) body)
 397   = (mapIdEnv markDangerousToDup final_usage,
 398      Lam (ValBinder tagged_binder) body')
 399   where
 400     (body_usage, body')          = occAnal (env `addNewCand` binder) body
 401     (final_usage, tagged_binder) = tagBinder body_usage binder
 402
 403 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 404 occAnal env (Lam (TyBinder tyvar) body)
 405   = (mapIdEnv markDangerousToDup body_usage,
 406      Lam (TyBinder tyvar) body')
 407   where
 408     (body_usage, body') = occAnal env body
 409
 410 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
 411
 412 occAnal env (Case scrut alts)
 413   = (scrut_usage `combineUsageDetails` alts_usage,
 414      Case scrut' alts')
 415   where
 416     (scrut_usage, scrut') = occAnal env scrut
 417     (alts_usage, alts')   = occAnalAlts env alts
 418
 419 occAnal env (Let bind body)
 420   = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
 421   where
 422     new_env                  = env `addNewCands` (bindersOf bind)
 423     (body_usage, body')      = occAnal new_env body
 424     (final_usage, new_binds) = occAnalBind env bind body_usage
 425 \end{code}
 426
 427 Case alternatives
 428 ~~~~~~~~~~~~~~~~~
 429 \begin{code}
 430 occAnalAlts env (AlgAlts alts deflt)
 431   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 432         -- Note: combine*Alts*UsageDetails...
 433      AlgAlts alts' deflt')
 434   where
 435     (alts_usage,  alts')  = unzip (map do_alt alts)
 436     (deflt_usage, deflt') = occAnalDeflt env deflt
 437
 438     do_alt (con, args, rhs)
 439       = (final_usage, (con, tagged_args, rhs'))
 440       where
 441         new_env            = env `addNewCands` args
 442         (rhs_usage, rhs')          = occAnal new_env rhs
 443         (final_usage, tagged_args) = tagBinders rhs_usage args
 444
 445 occAnalAlts env (PrimAlts alts deflt)
 446   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 447         -- Note: combine*Alts*UsageDetails...
 448      PrimAlts alts' deflt')
 449   where
 450     (alts_usage, alts')   = unzip (map do_alt alts)
 451     (deflt_usage, deflt') = occAnalDeflt env deflt
 452
 453     do_alt (lit, rhs)
 454       = (rhs_usage, (lit, rhs'))
 455       where
 456         (rhs_usage, rhs') = occAnal env rhs
 457
 458 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
 459
 460 occAnalDeflt env (BindDefault binder rhs)
 461   = (final_usage, BindDefault tagged_binder rhs')
 462   where
 463     new_env                      = env `addNewCand` binder
 464     (rhs_usage, rhs')            = occAnal new_env rhs
 465     (final_usage, tagged_binder) = tagBinder rhs_usage binder
 466 \end{code}
 467
 468
 469 Atoms
 470 ~~~~~
 471 \begin{code}
 472 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
 473
 474 occAnalArgs env atoms
 475   = foldr do_one_atom emptyDetails atoms
 476   where
 477     do_one_atom (VarArg v) usage
 478         | isCandidate env v = addOneOcc usage v (argOccurrence 0)
 479         | otherwise         = usage
 480     do_one_atom other_arg  usage = usage
 481
 482
 483 occAnalArg  :: OccEnv -> CoreArg -> UsageDetails
 484
 485 occAnalArg env (VarArg v)
 486   | isCandidate env v = unitDetails v (argOccurrence 0)
 487   | otherwise         = emptyDetails
 488 occAnalArg _   _      = emptyDetails
 489 \end{code}