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, isNullIdEnv,
  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  let
 127   usage' = usage `delManyFromIdEnv` binders
 128   uss    = [ (binder, usage_of usage binder) | binder <- binders ]
 129  in
 130  if isNullIdEnv usage' then
 131     (usage', uss)
 132  else
 133     (usage', uss)
 134 {-
 135   = (usage `delManyFromIdEnv` binders,
 136      [ (binder, usage_of usage binder) | binder <- binders ]
 137     )
 138 -}
 139 tagBinder :: UsageDetails           -- Of scope
 140           -> Id                     -- Binders
 141           -> (UsageDetails,         -- Details with binders removed
 142               (Id,BinderInfo))      -- Tagged binders
 143
 144 tagBinder usage binder =
 145  let
 146    usage'  = usage `delOneFromIdEnv` binder
 147    us      = usage_of usage binder
 148    cont =
 149     if isNullIdEnv usage' then  -- bogus test to force evaluation.
 150        (usage', (binder, us))
 151     else
 152        (usage', (binder, us))
 153  in
 154  case us of { DeadCode -> cont; _ -> cont }
 155
 156 --   (binder, usage_of usage binder)
 157
 158
 159 usage_of usage binder
 160   | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
 161   | otherwise
 162   = case (lookupIdEnv usage binder) of
 163       Nothing   -> DeadCode
 164       Just info -> info
 165
 166 isNeeded env usage binder
 167   = case (usage_of usage binder) of
 168       DeadCode  -> keepUnusedBinding env binder -- Maybe keep it anyway
 169       other     -> True
 170 \end{code}
 171
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection[OccurAnal-main]{Counting occurrences: main function}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 Here's the externally-callable interface:
 180
 181 \begin{code}
 182 occurAnalyseBinds
 183         :: [CoreBinding]                -- input
 184         -> (SimplifierSwitch -> Bool)
 185         -> [SimplifiableCoreBinding]    -- output
 186
 187 occurAnalyseBinds binds simplifier_sw_chkr
 188   | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
 189                                      (ppAboves (map (ppr PprDebug) binds'))
 190                                      binds'
 191   | otherwise             = binds'
 192   where
 193     (_, binds') = doo initial_env binds
 194
 195     initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
 196                          (simplifier_sw_chkr KeepSpecPragmaIds)
 197                          (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
 198                          (simplifier_sw_chkr IgnoreINLINEPragma)
 199                          emptyIdSet
 200
 201     doo env [] = (emptyDetails, [])
 202     doo env (bind:binds)
 203       = (final_usage, new_binds ++ the_rest)
 204       where
 205         new_env                  = env `addNewCands` (bindersOf bind)
 206         (binds_usage, the_rest)  = doo new_env binds
 207         (final_usage, new_binds) = occAnalBind env bind binds_usage
 208 \end{code}
 209
 210 \begin{code}
 211 occurAnalyseExpr :: IdSet               -- Set of interesting free vars
 212                  -> CoreExpr
 213                  -> (IdEnv BinderInfo,  -- Occ info for interesting free vars
 214                      SimplifiableCoreExpr)
 215
 216 occurAnalyseExpr candidates expr
 217   = occAnal initial_env expr
 218   where
 219     initial_env = OccEnv False {- Drop unused bindings -}
 220                          False {- Drop SpecPragmaId bindings -}
 221                          True  {- Keep conjurable Ids -}
 222                          False {- Do not ignore INLINE Pragma -}
 223                          candidates
 224
 225 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
 226 occurAnalyseGlobalExpr expr
 227   =     -- Top level expr, so no interesting free vars, and
 228         -- discard occurence info returned
 229     snd (occurAnalyseExpr emptyIdSet expr)
 230 \end{code}
 231
 232 %************************************************************************
 233 %*                                                                      *
 234 \subsection[OccurAnal-main]{Counting occurrences: main function}
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 Bindings
 239 ~~~~~~~~
 240
 241 \begin{code}
 242 occAnalBind :: OccEnv
 243             -> CoreBinding
 244             -> UsageDetails             -- Usage details of scope
 245             -> (UsageDetails,           -- Of the whole let(rec)
 246                 [SimplifiableCoreBinding])
 247
 248 occAnalBind env (NonRec binder rhs) body_usage
 249   | isNeeded env body_usage binder              -- It's mentioned in body
 250   = (final_body_usage `combineUsageDetails` rhs_usage,
 251      [NonRec tagged_binder rhs'])
 252
 253   | otherwise
 254   = (body_usage, [])
 255
 256   where
 257     (rhs_usage, rhs')                 = occAnalRhs env binder rhs
 258     (final_body_usage, tagged_binder) = tagBinder body_usage binder
 259 \end{code}
 260
 261 Dropping dead code for recursive bindings is done in a very simple way:
 262
 263         the entire set of bindings is dropped if none of its binders are
 264         mentioned in its body; otherwise none are.
 265
 266 This seems to miss an obvious improvement.
 267 @
 268         letrec  f = ...g...
 269                 g = ...f...
 270         in
 271         ...g...
 272
 273 ===>
 274
 275         letrec f = ...g...
 276                g = ...(...g...)...
 277         in
 278         ...g...
 279 @
 280
 281 Now @f@ is unused. But dependency analysis will sort this out into a
 282 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
 283 It isn't easy to do a perfect job in one blow.  Consider
 284
 285 @
 286         letrec f = ...g...
 287                g = ...h...
 288                h = ...k...
 289                k = ...m...
 290                m = ...m...
 291         in
 292         ...m...
 293 @
 294
 295
 296 \begin{code}
 297 occAnalBind env (Rec pairs) body_usage
 298   = foldr do_final_bind (body_usage, []) sccs
 299   where
 300
 301     (binders, rhss) = unzip pairs
 302     new_env         = env `addNewCands` binders
 303
 304     analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
 305     analysed_pairs  = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
 306
 307     lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
 308     lookup id =  assoc "occAnalBind:lookup" analysed_pairs id
 309
 310
 311     ---- stuff for dependency analysis of binds -------------------------------
 312
 313     edges :: [(Id,Id)]          -- (a,b) means a mentions b
 314     edges = concat [ edges_from binder rhs_usage
 315                    | (binder, (rhs_usage, _)) <- analysed_pairs]
 316
 317     edges_from :: Id -> UsageDetails -> [(Id,Id)]
 318     edges_from id its_rhs_usage
 319       = [(id,mentioned) | mentioned <- binders,
 320                           maybeToBool (lookupIdEnv its_rhs_usage mentioned)
 321         ]
 322
 323     sccs :: [[Id]]
 324     sccs = case binders of
 325                 [_]   -> [binders]      -- Singleton; no need to analyse
 326                 other -> stronglyConnComp (==) edges binders
 327
 328     ---- stuff to "re-constitute" bindings from dependency-analysis info ------
 329
 330     do_final_bind sCC@[binder] (body_usage, binds_so_far)
 331       | isNeeded env body_usage binder
 332       = (combined_usage, new_bind:binds_so_far)
 333
 334       | otherwise               -- Dead
 335       = (body_usage, binds_so_far)
 336       where
 337         total_usage                     = combineUsageDetails body_usage rhs_usage
 338         (rhs_usage, rhs')               = lookup binder
 339         (combined_usage, tagged_binder) = tagBinder total_usage binder
 340
 341         new_bind
 342           | mentions_itself binder rhs_usage = Rec [(tagged_binder,rhs')]
 343           | otherwise                        = NonRec tagged_binder rhs'
 344           where
 345             mentions_itself binder usage
 346               = maybeToBool (lookupIdEnv usage binder)
 347
 348     do_final_bind sCC (body_usage, binds_so_far)
 349       | any (isNeeded env body_usage) sCC
 350       = (combined_usage, new_bind:binds_so_far)
 351
 352       | otherwise               -- Dead
 353       = (body_usage, binds_so_far)
 354       where
 355         (rhs_usages, rhss')              = unzip (map lookup sCC)
 356         total_usage                      = foldr combineUsageDetails body_usage rhs_usages
 357         (combined_usage, tagged_binders) = tagBinders total_usage sCC
 358
 359         new_bind = Rec (zipEqual "occAnalBind" tagged_binders rhss')
 360 \end{code}
 361
 362 @occAnalRhs@ deals with the question of bindings where the Id is marked
 363 by an INLINE pragma.  For these we record that anything which occurs
 364 in its RHS occurs many times.  This pessimistically assumes that ths
 365 inlined binder also occurs many times in its scope, but if it doesn't
 366 we'll catch it next time round.  At worst this costs an extra simplifier pass.
 367 ToDo: try using the occurrence info for the inline'd binder.
 368
 369 \begin{code}
 370 occAnalRhs :: OccEnv
 371            -> Id        -- Binder
 372            -> CoreExpr  -- Rhs
 373            -> (UsageDetails, SimplifiableCoreExpr)
 374
 375 occAnalRhs env id rhs
 376   | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
 377   = (mapIdEnv markMany rhs_usage, rhs')
 378
 379   | otherwise
 380   = (rhs_usage, rhs')
 381
 382   where
 383     (rhs_usage, rhs') = occAnal env rhs
 384 \end{code}
 385
 386 Expressions
 387 ~~~~~~~~~~~
 388 \begin{code}
 389 occAnal :: OccEnv
 390         -> CoreExpr
 391         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
 392             SimplifiableCoreExpr)
 393
 394 occAnal env (Var v)
 395   | isCandidate env v
 396   = (unitIdEnv v (funOccurrence 0), Var v)
 397
 398   | otherwise
 399   = (emptyDetails, Var v)
 400
 401 occAnal env (Lit lit)      = (emptyDetails, Lit lit)
 402 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
 403 \end{code}
 404
 405 We regard variables that occur as constructor arguments as "dangerousToDup":
 406
 407 \begin{verbatim}
 408 module A where
 409 f x = let y = expensive x in
 410       let z = (True,y) in
 411       (case z of {(p,q)->q}, case z of {(p,q)->q})
 412 \end{verbatim}
 413
 414 We feel free to duplicate the WHNF (True,y), but that means
 415 that y may be duplicated thereby.
 416
 417 If we aren't careful we duplicate the (expensive x) call!
 418 Constructors are rather like lambdas in this way.
 419
 420 \begin{code}
 421 occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
 422                               Con con args)
 423
 424 occAnal env (SCC cc body)
 425   = (mapIdEnv markInsideSCC usage, SCC cc body')
 426   where
 427     (usage, body') = occAnal env body
 428
 429 occAnal env (Coerce c ty body)
 430   = (usage, Coerce c ty body')
 431   where
 432     (usage, body') = occAnal env body
 433
 434 occAnal env (App fun arg)
 435   = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
 436   where
 437     (fun_usage, fun') = occAnal    env fun
 438     arg_usage         = occAnalArg env arg
 439
 440 -- For value lambdas we do a special hack.  Consider
 441 --      (\x. \y. ...x...)
 442 -- If we did nothing, x is used inside the \y, so would be marked
 443 -- as dangerous to dup.  But in the common case where the abstraction
 444 -- is applied to two arguments this is over-pessimistic.
 445 -- So instead we don't take account of the \y when dealing with x's usage;
 446 -- instead, the simplifier is careful when partially applying lambdas
 447
 448 occAnal env expr@(Lam (ValBinder binder) body)
 449   = (mapIdEnv markDangerousToDup final_usage,
 450      foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
 451   where
 452     (binders,body)                = collectValBinders expr
 453     (body_usage, body')           = occAnal (env `addNewCands` binders) body
 454     (final_usage, tagged_binders) = tagBinders body_usage binders
 455
 456 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
 457 occAnal env (Lam (TyBinder tyvar) body)
 458   = case occAnal env body of { (body_usage, body') ->
 459      (mapIdEnv markDangerousToDup body_usage,
 460       Lam (TyBinder tyvar) body') }
 461 --  where
 462 --    (body_usage, body') = occAnal env body
 463
 464 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
 465
 466 occAnal env (Case scrut alts)
 467   = case occAnalAlts env alts of { (alts_usage, alts')   ->
 468      case occAnal env scrut   of { (scrut_usage, scrut') ->
 469        let
 470         det = scrut_usage `combineUsageDetails` alts_usage
 471        in
 472        if isNullIdEnv det then
 473           (det, Case scrut' alts')
 474        else
 475           (det, Case scrut' alts') }}
 476 {-
 477        (scrut_usage `combineUsageDetails` alts_usage,
 478         Case scrut' alts')
 479   where
 480     (scrut_usage, scrut') = occAnal env scrut
 481     (alts_usage, alts')   = occAnalAlts env alts
 482 -}
 483
 484 occAnal env (Let bind body)
 485   = case occAnal new_env body            of { (body_usage, body') ->
 486     case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
 487        (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
 488   where
 489     new_env                  = env `addNewCands` (bindersOf bind)
 490 --    (body_usage, body')      = occAnal new_env body
 491 --    (final_usage, new_binds) = occAnalBind env bind body_usage
 492 \end{code}
 493
 494 Case alternatives
 495 ~~~~~~~~~~~~~~~~~
 496 \begin{code}
 497 occAnalAlts env (AlgAlts alts deflt)
 498   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 499         -- Note: combine*Alts*UsageDetails...
 500      AlgAlts alts' deflt')
 501   where
 502     (alts_usage,  alts')  = unzip (map do_alt alts)
 503     (deflt_usage, deflt') = occAnalDeflt env deflt
 504
 505     do_alt (con, args, rhs)
 506       = (final_usage, (con, tagged_args, rhs'))
 507       where
 508         new_env            = env `addNewCands` args
 509         (rhs_usage, rhs')          = occAnal new_env rhs
 510         (final_usage, tagged_args) = tagBinders rhs_usage args
 511
 512 occAnalAlts env (PrimAlts alts deflt)
 513   = (foldr combineAltsUsageDetails deflt_usage alts_usage,
 514         -- Note: combine*Alts*UsageDetails...
 515      PrimAlts alts' deflt')
 516   where
 517     (alts_usage, alts')   = unzip (map do_alt alts)
 518     (deflt_usage, deflt') = occAnalDeflt env deflt
 519
 520     do_alt (lit, rhs)
 521       = (rhs_usage, (lit, rhs'))
 522       where
 523         (rhs_usage, rhs') = occAnal env rhs
 524
 525 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
 526
 527 occAnalDeflt env (BindDefault binder rhs)
 528   = (final_usage, BindDefault tagged_binder rhs')
 529   where
 530     new_env                      = env `addNewCand` binder
 531     (rhs_usage, rhs')            = occAnal new_env rhs
 532     (final_usage, tagged_binder) = tagBinder rhs_usage binder
 533 \end{code}
 534
 535
 536 Atoms
 537 ~~~~~
 538 \begin{code}
 539 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
 540
 541 occAnalArgs env atoms
 542   = foldr do_one_atom emptyDetails atoms
 543   where
 544     do_one_atom (VarArg v) usage
 545         | isCandidate env v = addOneOcc usage v (argOccurrence 0)
 546         | otherwise         = usage
 547     do_one_atom other_arg  usage = usage
 548
 549
 550 occAnalArg  :: OccEnv -> CoreArg -> UsageDetails
 551
 552 occAnalArg env (VarArg v)
 553   | isCandidate env v = unitDetails v (argOccurrence 0)
 554   | otherwise         = emptyDetails
 555 occAnalArg _   _      = emptyDetails
 556 \end{code}