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                           emptyIdSet, unionIdSets, mkIdSet,
  29                           unitIdSet, elementOfIdSet,
  30                           addOneToIdSet, SYN_IE(IdSet),
  31                           nullIdEnv, unitIdEnv, combineIdEnvs,
  32                           delOneFromIdEnv, delManyFromIdEnv,
  33                           mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
  34                           GenId{-instance Eq-}
  35                         )
  36 import Name             ( isExported )
  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   | isExported 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 (Prim op args) = (occAnalArgs env args, Prim op args)
 384 \end{code}
 385
 386 We regard variables that occur as constructor arguments as "dangerousToDup":
 387
 388 \begin{verbatim}
 389 module A where
 390 f x = let y = expensive x in
 391       let z = (True,y) in
 392       (case z of {(p,q)->q}, case z of {(p,q)->q})
 393 \end{verbatim}
 394
 395 We feel free to duplicate the WHNF (True,y), but that means
 396 that y may be duplicated thereby.
 397
 398 If we aren't careful we duplicate the (expensive x) call!
 399 Constructors are rather like lambdas in this way.
 400
 401 \begin{code}
 402 occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
 403                               Con con args)
 404
 405 occAnal env (SCC cc body)
 406   = (mapIdEnv markInsideSCC usage, SCC cc body')
 407   where
 408     (usage, body') = occAnal env body
 409
 410 occAnal env (Coerce c ty body)
 411   = (usage, Coerce c ty body')
 412   where
 413     (usage, body') = occAnal env body
 414
 415 occAnal env (App fun arg)
 416   = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
 417   where
 418     (fun_usage, fun') = occAnal    env fun
 419     arg_usage         = occAnalArg env arg
 420
 421 -- For value lambdas we do a special hack.  Consider
 422 --      (\x. \y. ...x...)
 423 -- If we did nothing, x is used inside the \y, so would be marked
 424 -- as dangerous to dup.  But in the common case where the abstraction
 425 -- is applied to two arguments this is over-pessimistic.
 426 -- So instead we don't take account of the \y when dealing with x's usage;
 427 -- instead, the simplifier is careful when partially applying lambdas
 428
 429 occAnal env expr@(Lam (ValBinder binder) body)
 430   = (mapIdEnv markDangerousToDup final_usage,
 431      foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
 432   where
 433     (binders,body)                = collectValBinders expr
 434     (body_usage, body')           = occAnal (env `addNewCands` binders) body
 435     (final_usage, tagged_binders) = tagBinders body_usage binders
 436
 437 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 438 occAnal env (Lam (TyBinder tyvar) body)
 439   = (mapIdEnv markDangerousToDup body_usage,
 440      Lam (TyBinder tyvar) body')
 441   where
 442     (body_usage, body') = occAnal env body
 443
 444 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
 445
 446 occAnal env (Case scrut alts)
 447   = (scrut_usage `combineUsageDetails` alts_usage,
 448      Case scrut' alts')
 449   where
 450     (scrut_usage, scrut') = occAnal env scrut
 451     (alts_usage, alts')   = occAnalAlts env alts
 452
 453 occAnal env (Let bind body)
 454   = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
 455   where
 456     new_env                  = env `addNewCands` (bindersOf bind)
 457     (body_usage, body')      = occAnal new_env body
 458     (final_usage, new_binds) = occAnalBind env bind body_usage
 459 \end{code}
 460
 461 Case alternatives
 462 ~~~~~~~~~~~~~~~~~
 463 \begin{code}
 464 occAnalAlts env (AlgAlts alts deflt)
 465   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 466         -- Note: combine*Alts*UsageDetails...
 467      AlgAlts alts' deflt')
 468   where
 469     (alts_usage,  alts')  = unzip (map do_alt alts)
 470     (deflt_usage, deflt') = occAnalDeflt env deflt
 471
 472     do_alt (con, args, rhs)
 473       = (final_usage, (con, tagged_args, rhs'))
 474       where
 475         new_env            = env `addNewCands` args
 476         (rhs_usage, rhs')          = occAnal new_env rhs
 477         (final_usage, tagged_args) = tagBinders rhs_usage args
 478
 479 occAnalAlts env (PrimAlts alts deflt)
 480   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 481         -- Note: combine*Alts*UsageDetails...
 482      PrimAlts alts' deflt')
 483   where
 484     (alts_usage, alts')   = unzip (map do_alt alts)
 485     (deflt_usage, deflt') = occAnalDeflt env deflt
 486
 487     do_alt (lit, rhs)
 488       = (rhs_usage, (lit, rhs'))
 489       where
 490         (rhs_usage, rhs') = occAnal env rhs
 491
 492 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
 493
 494 occAnalDeflt env (BindDefault binder rhs)
 495   = (final_usage, BindDefault tagged_binder rhs')
 496   where
 497     new_env                      = env `addNewCand` binder
 498     (rhs_usage, rhs')            = occAnal new_env rhs
 499     (final_usage, tagged_binder) = tagBinder rhs_usage binder
 500 \end{code}
 501
 502
 503 Atoms
 504 ~~~~~
 505 \begin{code}
 506 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
 507
 508 occAnalArgs env atoms
 509   = foldr do_one_atom emptyDetails atoms
 510   where
 511     do_one_atom (VarArg v) usage
 512         | isCandidate env v = addOneOcc usage v (argOccurrence 0)
 513         | otherwise         = usage
 514     do_one_atom other_arg  usage = usage
 515
 516
 517 occAnalArg  :: OccEnv -> CoreArg -> UsageDetails
 518
 519 occAnalArg env (VarArg v)
 520   | isCandidate env v = unitDetails v (argOccurrence 0)
 521   | otherwise         = emptyDetails
 522 occAnalArg _   _      = emptyDetails
 523 \end{code}