ghc/compiler/simplCore/SimplEnv.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[SimplEnv]{Environment stuff for the simplifier}
   5
   6 \begin{code}
   7 module SimplEnv (
   8         nullSimplEnv, combineSimplEnv,
   9         pprSimplEnv, -- debugging only
  10
  11         extendTyEnv, extendTyEnvList, extendTyEnvEnv,
  12         simplTy, simplTyInId,
  13
  14         extendIdEnvWithAtom, extendIdEnvWithAtoms,
  15         extendIdEnvWithClone, extendIdEnvWithClones,
  16         lookupId,
  17
  18
  19         markDangerousOccs,
  20         lookupRhsInfo, lookupOutIdEnv, isEvaluated,
  21         extendEnvGivenBinding, extendEnvGivenNewRhs,
  22         extendEnvGivenRhsInfo, extendEnvGivenInlining,
  23
  24         lookForConstructor,
  25
  26         getSwitchChecker, switchIsSet, getSimplIntSwitch,
  27         switchOffInlining, setCaseScrutinee,
  28
  29         setEnclosingCC, getEnclosingCC,
  30
  31         -- Types
  32         SwitchChecker,
  33         SimplEnv,
  34         InIdEnv, InTypeEnv,
  35         UnfoldConApp,
  36         RhsInfo(..),
  37
  38         InId,  InBinder,  InBinding,  InType,
  39         OutId, OutBinder, OutBinding, OutType,
  40
  41         InExpr,  InAlts,  InDefault,  InArg,
  42         OutExpr, OutAlts, OutDefault, OutArg
  43     ) where
  44
  45 #include "HsVersions.h"
  46
  47 import BinderInfo       ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc,
  48                           okToInline,
  49                           BinderInfo {-instances, too-}
  50                         )
  51 import CmdLineOpts      ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
  52                           SimplifierSwitch(..), SwitchResult(..)
  53                         )
  54 import CoreSyn
  55 import CoreUnfold       ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
  56                           Unfolding(..), SimpleUnfolding(..), FormSummary(..),
  57                           calcUnfoldingGuidance )
  58 import CoreUtils        ( coreExprCc )
  59 import CostCentre       ( CostCentre, subsumedCosts, noCostCentreAttached )
  60 import FiniteMap        -- lots of things
  61 import Id               ( applyTypeEnvToId, getInlinePragma,
  62                           nullIdEnv, growIdEnvList, lookupIdEnv,
  63                           addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly,
  64                           IdEnv, IdSet, GenId, Id )
  65 import Literal          ( Literal{-instances-} )
  66 import Maybes           ( expectJust )
  67 import OccurAnal        ( occurAnalyseExpr )
  68 import PprCore          -- various instances
  69 import PprType          ( GenType, GenTyVar )
  70 import Type             ( instantiateTy, Type )
  71 import TyVar            ( emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList,
  72                           TyVarEnv, GenTyVar{-instance Eq-} ,
  73                           TyVar
  74                         )
  75 import Unique           ( Unique{-instance Outputable-}, Uniquable(..) )
  76 import UniqFM           ( addToUFM, addToUFM_C, ufmToList )
  77 import Util             ( Eager, returnEager, zipEqual, thenCmp, cmpList )
  78 import Outputable
  79 \end{code}
  80
  81 %************************************************************************
  82 %*                                                                      *
  83 \subsection[Simplify-types]{Type declarations}
  84 %*                                                                      *
  85 %************************************************************************
  86
  87 \begin{code}
  88 type InId      = Id                     -- Not yet cloned
  89 type InBinder  = (InId, BinderInfo)
  90 type InType    = Type                   -- Ditto
  91 type InBinding = SimplifiableCoreBinding
  92 type InExpr    = SimplifiableCoreExpr
  93 type InAlts    = SimplifiableCoreCaseAlts
  94 type InDefault = SimplifiableCoreCaseDefault
  95 type InArg     = SimplifiableCoreArg
  96
  97 type OutId      = Id                    -- Cloned
  98 type OutBinder  = Id
  99 type OutType    = Type                  -- Cloned
 100 type OutBinding = CoreBinding
 101 type OutExpr    = CoreExpr
 102 type OutAlts    = CoreCaseAlts
 103 type OutDefault = CoreCaseDefault
 104 type OutArg     = CoreArg
 105
 106 type SwitchChecker = SimplifierSwitch -> SwitchResult
 107 \end{code}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsubsection{The @SimplEnv@ type}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115
 116 INVARIANT: we assume {\em no shadowing}.  (ToDo: How can we ASSERT
 117 this? WDP 94/06) This allows us to neglect keeping everything paired
 118 with its static environment.
 119
 120 The environment contains bindings for all
 121         {\em in-scope,}
 122         {\em locally-defined}
 123 things.
 124
 125 For such things, any unfolding is found in the environment, not in the
 126 Id.  Unfoldings in the Id itself are used only for imported things
 127 (otherwise we get trouble because we have to simplify the unfoldings
 128 inside the Ids, etc.).
 129
 130 \begin{code}
 131 data SimplEnv
 132   = SimplEnv
 133         SwitchChecker
 134         CostCentre              -- The enclosing cost-centre (when profiling)
 135         InTypeEnv               -- Maps old type variables to new clones
 136         InIdEnv                 -- Maps locally-bound Ids to new clones
 137         OutIdEnv                -- Info about the values of OutIds
 138         ConAppMap               -- Maps constructor applications back to OutIds
 139
 140
 141 nullSimplEnv :: SwitchChecker -> SimplEnv
 142
 143 nullSimplEnv sw_chkr
 144   = SimplEnv sw_chkr subsumedCosts emptyTyVarEnv nullIdEnv nullIdEnv nullConApps
 145
 146 combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
 147 combineSimplEnv env@(SimplEnv chkr _       _      _         out_id_env con_apps)
 148             new_env@(SimplEnv _    encl_cc ty_env in_id_env _          _       )
 149   = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
 150
 151 pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
 152 \end{code}
 153
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 \subsubsection{Command-line switches}
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 \begin{code}
 162 getSwitchChecker :: SimplEnv -> SwitchChecker
 163 getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
 164
 165 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
 166 switchIsSet (SimplEnv chkr _ _ _ _ _) switch
 167   = switchIsOn chkr switch
 168
 169 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 170 getSimplIntSwitch chkr switch
 171   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 172
 173         -- Crude, but simple
 174 setCaseScrutinee :: SimplEnv -> SimplEnv
 175 setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 176   = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
 177   where
 178     chkr' SimplCaseScrutinee = SwBool True
 179     chkr' other              = chkr other
 180 \end{code}
 181
 182 @switchOffInlining@ is used to prepare the environment for simplifying
 183 the RHS of an Id that's marked with an INLINE pragma.  It is going to
 184 be inlined wherever they are used, and then all the inlining will take
 185 effect.  Meanwhile, there isn't much point in doing anything to the
 186 as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
 187 inlining!  because
 188         (a) not doing so will inline a worker straight back into its wrapper!
 189
 190 and     (b) Consider the following example
 191                 let f = \pq -> BIG
 192                 in
 193                 let g = \y -> f y y
 194                     {-# INLINE g #-}
 195                 in ...g...g...g...g...g...
 196
 197         Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 198         and thence copied multiple times when g is inlined.
 199
 200         Andy disagrees! Example:
 201                 all xs = foldr (&&) True xs
 202                 any p = all . map p  {-# INLINE any #-}
 203
 204         Problem: any won't get deforested, and so if it's exported and
 205         the importer doesn't use the inlining, (eg passes it as an arg)
 206         then we won't get deforestation at all.
 207         We havn't solved this problem yet!
 208
 209 We prepare the envt by simply discarding the out_id_env, which has
 210 all the unfolding info. At one point we did it by modifying the chkr so
 211 that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
 212 simplifications happening in the body of the RHS.
 213
 214 \begin{code}
 215 switchOffInlining :: SimplEnv -> SimplEnv
 216 switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 217   = SimplEnv chkr encl_cc ty_env in_id_env nullIdEnv nullConApps
 218 \end{code}
 219
 220 %************************************************************************
 221 %*                                                                      *
 222 \subsubsection{The ``enclosing cost-centre''}
 223 %*                                                                      *
 224 %************************************************************************
 225
 226 \begin{code}
 227 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
 228
 229 setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
 230   = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
 231
 232 getEnclosingCC :: SimplEnv -> CostCentre
 233 getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
 234 \end{code}
 235
 236 %************************************************************************
 237 %*                                                                      *
 238 \subsubsection{The @TypeEnv@ part}
 239 %*                                                                      *
 240 %************************************************************************
 241
 242 \begin{code}
 243 type TypeEnv = TyVarEnv Type
 244 type InTypeEnv = TypeEnv        -- Maps InTyVars to OutTypes
 245
 246 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
 247 extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
 248   = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
 249   where
 250     new_ty_env = addToTyVarEnv ty_env tyvar ty
 251
 252 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
 253 extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
 254   = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
 255   where
 256     new_ty_env = growTyVarEnvList ty_env pairs
 257
 258 extendTyEnvEnv :: SimplEnv -> TypeEnv -> SimplEnv
 259 extendTyEnvEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) new_ty_env
 260   = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
 261   where
 262     new_ty_env = ty_env `plusTyVarEnv` new_ty_env
 263
 264 simplTy     (SimplEnv _ _ ty_env _ _ _) ty = returnEager (instantiateTy ty_env ty)
 265 simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id)
 266 \end{code}
 267
 268 %************************************************************************
 269 %*                                                                      *
 270 \subsubsection{The ``Id env'' part}
 271 %*                                                                      *
 272 %************************************************************************
 273
 274 \begin{code}
 275 type InIdEnv = IdEnv OutArg     -- Maps InIds to their value
 276                                 -- Usually this is just the cloned Id, but if
 277                                 -- if the orig defn is a let-binding, and
 278                                 -- the RHS of the let simplifies to an atom,
 279                                 -- we just bind the variable to that atom, and
 280                                 -- elide the let.
 281 \end{code}
 282
 283 \begin{code}
 284 lookupId :: SimplEnv -> Id -> Eager ans OutArg
 285
 286 lookupId (SimplEnv _ _ _ in_id_env _ _) id
 287   = case (lookupIdEnv in_id_env id) of
 288       Just atom -> returnEager atom
 289       Nothing   -> returnEager (VarArg id)
 290 \end{code}
 291
 292 \begin{code}
 293 extendIdEnvWithAtom
 294         :: SimplEnv
 295         -> InBinder
 296         -> OutArg{-Val args only, please-}
 297         -> SimplEnv
 298
 299 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 300                     (in_id,occ_info) atom
 301   = case atom of
 302      LitArg _      -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 303      VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env
 304                                (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps
 305 --SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
 306   where
 307     new_in_id_env  = addOneToIdEnv in_id_env in_id atom
 308 {-
 309     new_out_id_env = case atom of
 310                         LitArg _      -> out_id_env
 311                         VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
 312 -}
 313
 314 extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
 315 extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 316
 317
 318 extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
 319
 320 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 321                      (in_id,_) out_id
 322   = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 323   where
 324     new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
 325
 326 extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
 327 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 328                       in_binders out_ids
 329   = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 330   where
 331     new_in_id_env = growIdEnvList in_id_env bindings
 332     bindings      = zipEqual "extendIdEnvWithClones"
 333                              [id | (id,_) <- in_binders]
 334                              (map VarArg out_ids)
 335 \end{code}
 336
 337 %************************************************************************
 338 %*                                                                      *
 339 \subsubsection{The @OutIdEnv@}
 340 %*                                                                      *
 341 %************************************************************************
 342
 343
 344 The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
 345 both locally-bound ones, and perhaps some imported ones too.
 346
 347 \begin{code}
 348 type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
 349
 350 \end{code}
 351
 352 The "Id" part is just so that we can recover the domain of the mapping, which
 353 IdEnvs don't allow directly.
 354
 355 The @BinderInfo@ tells about the occurrences of the @OutId@.
 356 Anything that isn't in here should be assumed to occur many times.
 357 We keep this info so we can modify it when something changes.
 358
 359 The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
 360
 361 \begin{code}
 362 data RhsInfo = NoRhsInfo
 363              | OtherLit [Literal]               -- It ain't one of these
 364              | OtherCon [Id]                    -- It ain't one of these
 365
 366                 -- InUnfolding is used for let(rec) bindings that
 367                 -- are *definitely* going to be inlined.
 368                 -- We record the un-simplified RHS and drop the binding
 369              | InUnfolding SimplEnv             -- Un-simplified unfolding
 370                            SimplifiableCoreExpr -- (need to snag envts therefore)
 371
 372              | OutUnfolding CostCentre
 373                             SimpleUnfolding     -- Already-simplified unfolding
 374
 375 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
 376 lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
 377
 378 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
 379 lookupRhsInfo env id
 380   = case lookupOutIdEnv env id of
 381         Just (_,_,info) -> info
 382         Nothing         -> NoRhsInfo
 383
 384 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
 385                  -> (OutId, BinderInfo, RhsInfo)
 386                  -> (OutId, BinderInfo, RhsInfo)
 387 modifyOutEnvItem (id, occ, info1) (_, _, info2)
 388   = case (info1, info2) of
 389                 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
 390                 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
 391                 (_,            NoRhsInfo)    -> (id,occ, info1)
 392                 other                        -> (id,occ, info2)
 393 \end{code}
 394
 395
 396 \begin{code}
 397 isEvaluated :: RhsInfo -> Bool
 398 isEvaluated (OtherLit _) = True
 399 isEvaluated (OtherCon _) = True
 400 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
 401 isEvaluated other = False
 402 \end{code}
 403
 404
 405
 406 \begin{code}
 407 mkSimplUnfoldingGuidance chkr out_id rhs
 408   = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
 409
 410 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
 411 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 412                       out_id occ_info rhs_info
 413   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 414   where
 415     new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
 416                                 (out_id, occ_info, rhs_info)
 417 \end{code}
 418
 419
 420 \begin{code}
 421 modifyOccInfo out_id_env (uniq, new_occ)
 422   = modifyIdEnv_Directly modify_fn out_id_env uniq
 423   where
 424     modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
 425
 426 markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
 427   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 428   where
 429     new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
 430     modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
 431 \end{code}
 432
 433
 434 \begin{code}
 435 extendEnvGivenInlining :: SimplEnv -> Id -> BinderInfo -> InExpr -> SimplEnv
 436 extendEnvGivenInlining env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 437                        id occ_info rhs
 438   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 439   where
 440     new_out_id_env = addToUFM out_id_env id (id, occ_info, InUnfolding env rhs)
 441 \end{code}
 442
 443 %************************************************************************
 444 %*                                                                      *
 445 \subsubsection{The @ConAppMap@ type}
 446 %*                                                                      *
 447 %************************************************************************
 448
 449 The @ConAppMap@ maps applications of constructors (to value atoms)
 450 back to an association list that says "if the constructor was applied
 451 to one of these lists-of-Types, then this OutId is your man (in a
 452 non-gender-specific sense)".  I.e., this is a reversed mapping for
 453 (part of) the main OutIdEnv
 454
 455 \begin{code}
 456 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
 457
 458 data UnfoldConApp
 459   = UCA         OutId                   -- data constructor
 460                 [OutArg]                -- *value* arguments; see use below
 461 \end{code}
 462
 463 \begin{code}
 464 nullConApps = emptyFM
 465
 466 extendConApps con_apps id (Con con args)
 467   = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
 468   where
 469     val_args = filter isValArg args             -- Literals and Ids
 470     ty_args  = [ty | TyArg ty <- args]          -- Just types
 471
 472 extendConApps con_apps id other_rhs = con_apps
 473 \end{code}
 474
 475 \begin{code}
 476 lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
 477   = case lookupFM con_apps (UCA con val_args) of
 478         Nothing     -> Nothing
 479
 480         Just assocs -> case [id | (tys, id) <- assocs,
 481                                   and (zipWith (==) tys ty_args)]
 482                        of
 483                           []     -> Nothing
 484                           (id:_) -> Just id
 485   where
 486     val_args = filter isValArg args             -- Literals and Ids
 487     ty_args  = [ty | TyArg ty <- args]          -- Just types
 488
 489 \end{code}
 490
 491 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
 492 for nullary constructors, but now we only do constructor re-use in
 493 let-bindings the special case isn't necessary any more.
 494
 495 \begin{verbatim}
 496   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 497         -- let
 498         --        a = leInt#! p q
 499         -- in
 500         -- case a of
 501         --    True  -> ...
 502         --    False -> False
 503         --
 504         -- Here the False in the second case will get replace by "a", hardly
 505         -- a good idea
 506     Nothing
 507 \end{verbatim}
 508
 509
 510 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 511 it, so we can use it for a @FiniteMap@ key.
 512
 513 \begin{code}
 514 instance Eq  UnfoldConApp where
 515     a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
 516     a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }
 517
 518 instance Ord UnfoldConApp where
 519     a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
 520     a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
 521     a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
 522     a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
 523     compare a b = cmp_app a b
 524
 525 cmp_app (UCA c1 as1) (UCA c2 as2)
 526   = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2
 527   where
 528     -- ToDo: make an "instance Ord CoreArg"???
 529
 530     cmp_arg (VarArg   x) (VarArg   y) = x `compare` y
 531     cmp_arg (LitArg   x) (LitArg   y) = x `compare` y
 532     cmp_arg (TyArg    x) (TyArg    y) = panic "SimplEnv.cmp_app:TyArgs"
 533     cmp_arg x y
 534       | tag x _LT_ tag y = LT
 535       | otherwise        = GT
 536       where
 537         tag (VarArg   _) = ILIT(1)
 538         tag (LitArg   _) = ILIT(2)
 539         tag (TyArg    _) = panic# "SimplEnv.cmp_app:TyArg"
 540 \end{code}
 541
 542
 543 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 544 of a new binding.  There is a horrid case we have to take care about,
 545 due to Andr\'e Santos:
 546 @
 547     type Array_type b   = Array Int b;
 548     type Descr_type     = (Int,Int);
 549
 550     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 551     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 552
 553     f_iaamain a_xs=
 554         let {
 555             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 556             f_aareorder a_index a_ar=
 557                 let {
 558                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 559                  } in  tabulate f_aareorder' (bounds a_ar);
 560             r_index=tabulate ((+) 1) (1,1);
 561             arr    = listArray (1,1) a_xs;
 562             arg    = f_aareorder r_index arr
 563          } in  elems arg
 564 @
 565 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 566 @
 567         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 568                in tabulate f_aareorder' (bounds arr)
 569 @
 570 Note that r_index is not inlined, because it was bound to a_index which
 571 occurs inside a lambda.
 572
 573 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 574 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 575 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 576 will get inlined inside the lambda.  AARGH.
 577
 578 Solution: when we occurrence-analyse the new RHS we have to go back
 579 and modify the info recorded in the UnfoldEnv for the free vars
 580 of the RHS.  In the example we'd go back and record that r_index is now used
 581 inside a lambda.
 582
 583 \begin{code}
 584 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 585 extendEnvGivenNewRhs env out_id rhs
 586   = extendEnvGivenBinding env noBinderInfo out_id rhs
 587
 588 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
 589 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 590                       occ_info out_id rhs
 591   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
 592   where
 593     new_out_id_env | okToInline (whnfOrBottom form)
 594                                 (couldBeSmallEnoughToInline guidance)
 595                                 occ_info
 596                    = out_id_env_with_unfolding
 597                    | otherwise
 598                    = out_id_env
 599         -- Don't bother to extend the OutIdEnv unless there is some possibility
 600         -- that the thing might be inlined.  We check this by calling okToInline suitably.
 601
 602     new_con_apps = _scc_ "eegnr.conapps"
 603                    extendConApps con_apps out_id rhs
 604
 605         -- Modify the occ info for rhs's interesting free variables.
 606     out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
 607                                 foldl modifyOccInfo env1 full_fv_occ_info
 608                 -- NB: full_fv_occ_info *combines* the occurrence of the current binder
 609                 -- with the occurrences of its RHS's free variables.  That's to take
 610                 -- account of:
 611                 --              let a = \x -> BIG in
 612                 --              let b = \f -> f a
 613                 --              in ...b...b...b...
 614                 -- Here "a" occurs exactly once. "b" simplifies to a small value.
 615                 -- So "b" will be inlined at each call site, and there's a good chance
 616                 -- that "a" will too.  So we'd better modify "a"s occurrence info to
 617                 -- record the fact that it can now occur many times by virtue that "b" can.
 618
 619     full_fv_occ_info          = _scc_ "eegnr.full_fv"
 620                                 [ (uniq, fv_occ `andBinderInfo` occ_info)
 621                                 | (uniq, fv_occ) <- ufmToList fv_occ_info
 622                                 ]
 623
 624         -- Add an unfolding and rhs_info for the new Id.
 625         -- If the out_id is already in the OutIdEnv (which can happen if
 626         -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
 627         -- then just replace the unfolding, leaving occurrence info alone.
 628     env1                      = _scc_ "eegnr.modify_out"
 629                                 addToUFM_C modifyOutEnvItem out_id_env out_id
 630                                            (out_id, occ_info, rhs_info)
 631
 632         -- Occurrence-analyse the RHS
 633         -- The "interesting" free variables we want occurrence info for are those
 634         -- in the OutIdEnv that have only a single occurrence right now.
 635     (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
 636                               occurAnalyseExpr is_interesting rhs
 637
 638     is_interesting v        = _scc_ "eegnr.mkidset"
 639                               case lookupIdEnv out_id_env v of
 640                                 Just (_, occ, _) -> isOneOcc occ
 641                                 other            -> False
 642
 643         -- Compute unfolding details
 644     rhs_info = OutUnfolding unf_cc (SimpleUnfolding form guidance template)
 645     form     = _scc_ "eegnr.form_sum"
 646                mkFormSummary rhs
 647     guidance = _scc_ "eegnr.guidance"
 648                mkSimplUnfoldingGuidance chkr out_id rhs
 649
 650         -- Compute cost centre for thing
 651     unf_cc  | noCostCentreAttached expr_cc = encl_cc
 652             | otherwise                    = expr_cc
 653             where
 654               expr_cc =  coreExprCc rhs
 655 \end{code}