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