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