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,
   9         getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
  10
  11         bindTyVar, bindTyVars, simplTy,
  12
  13         lookupIdSubst, lookupOutIdEnv,
  14
  15         bindIdToAtom, bindIdToExpr,
  16
  17         markDangerousOccs,
  18         lookupUnfolding, isEvaluated,
  19         extendEnvGivenBinding, extendEnvGivenNewRhs,
  20         extendEnvGivenUnfolding,
  21
  22         lookForConstructor,
  23
  24         getSwitchChecker, switchIsSet, getSimplIntSwitch,
  25         switchOffInlining, setCaseScrutinee,
  26
  27         setEnclosingCC, getEnclosingCC,
  28
  29         -- Types
  30         SwitchChecker,
  31         SimplEnv,
  32         UnfoldConApp,
  33         SubstInfo(..),
  34
  35         InId,  InBinder,  InBinding,  InType,
  36         OutId, OutBinder, OutBinding, OutType,
  37
  38         InExpr,  InAlts,  InDefault,  InArg,
  39         OutExpr, OutAlts, OutDefault, OutArg
  40     ) where
  41
  42 #include "HsVersions.h"
  43
  44 import BinderInfo       ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc,
  45                           okToInline, isOneFunOcc,
  46                           BinderInfo
  47                         )
  48 import CmdLineOpts      ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
  49                           SimplifierSwitch(..), SwitchResult(..)
  50                         )
  51 import CoreSyn
  52 import CoreUnfold       ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
  53                           Unfolding(..), FormSummary(..),
  54                           calcUnfoldingGuidance )
  55 import CoreUtils        ( coreExprCc )
  56 import CostCentre       ( CostCentre, isCurrentCostCentre, useCurrentCostCentre, costsAreSubsumed, noCostCentreAttached )
  57 import FiniteMap        -- lots of things
  58 import Id               ( getInlinePragma,
  59                           nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv,
  60                           addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly,
  61                           IdEnv, IdSet, Id )
  62 import Literal          ( Literal )
  63 import Maybes           ( expectJust )
  64 import OccurAnal        ( occurAnalyseExpr )
  65 import PprCore          -- various instances
  66 import Type             ( instantiateTy, Type )
  67 import TyVar            ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList,
  68                           TyVarSet, emptyTyVarSet,
  69                           TyVar
  70                         )
  71 import Unique           ( Unique{-instance Outputable-}, Uniquable(..) )
  72 import UniqFM           ( addToUFM, addToUFM_C, ufmToList, mapUFM )
  73 import Util             ( Eager, returnEager, zipEqual, thenCmp, cmpList )
  74 import Outputable
  75 \end{code}
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection[Simplify-types]{Type declarations}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 type InId      = Id                     -- Not yet cloned
  85 type InBinder  = (InId, BinderInfo)
  86 type InType    = Type                   -- Ditto
  87 type InBinding = SimplifiableCoreBinding
  88 type InExpr    = SimplifiableCoreExpr
  89 type InAlts    = SimplifiableCoreCaseAlts
  90 type InDefault = SimplifiableCoreCaseDefault
  91 type InArg     = SimplifiableCoreArg
  92
  93 type OutId      = Id                    -- Cloned
  94 type OutBinder  = Id
  95 type OutType    = Type                  -- Cloned
  96 type OutBinding = CoreBinding
  97 type OutExpr    = CoreExpr
  98 type OutAlts    = CoreCaseAlts
  99 type OutDefault = CoreCaseDefault
 100 type OutArg     = CoreArg
 101
 102 type SwitchChecker = SimplifierSwitch -> SwitchResult
 103 \end{code}
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsubsection{The @SimplEnv@ type}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111
 112 INVARIANT: we assume {\em no shadowing}.  (ToDo: How can we ASSERT
 113 this? WDP 94/06) This allows us to neglect keeping everything paired
 114 with its static environment.
 115
 116 The environment contains bindings for all
 117         {\em in-scope,}
 118         {\em locally-defined}
 119 things.
 120
 121 For such things, any unfolding is found in the environment, not in the
 122 Id.  Unfoldings in the Id itself are used only for imported things
 123 (otherwise we get trouble because we have to simplify the unfoldings
 124 inside the Ids, etc.).
 125
 126 \begin{code}
 127 data SimplEnv
 128   = SimplEnv
 129         SwitchChecker
 130         CostCentre              -- The enclosing cost-centre (when profiling)
 131         SimplTypeEnv            -- Maps old type variables to new clones
 132         SimplValEnv             -- Maps locally-bound Ids to new clones
 133         ConAppMap               -- Maps constructor applications back to OutIds
 134
 135 type SimplTypeEnv = (TyVarSet,          -- In-scope tyvars (in result)
 136                      TyVarEnv Type)     -- Type substitution
 137         -- If t is in the in-scope set, it certainly won't be
 138         -- in the domain of the substitution, and vice versa
 139
 140 type SimplValEnv = (IdEnv StuffAboutId, -- Domain includes *all* in-scope
 141                                         -- Ids (in result), range gives info about them
 142                     IdEnv SubstInfo)    -- Id substitution
 143         -- The first envt tells what Ids are in scope; it
 144         -- corresponds to the TyVarSet in SimplTypeEnv
 145
 146         -- The substitution usually maps an Id to its clone,
 147         -- but if the orig defn is a let-binding, and
 148         -- the RHS of the let simplifies to an atom,
 149         -- we just add the binding to the substitution and elide the let.
 150         --
 151         -- Ids in the domain of the substitution are *not* in scope;
 152         -- they *must* be substituted for the given OutArg
 153
 154 data SubstInfo
 155   = SubstVar OutId              -- The Id maps to an already-substituted atom
 156   | SubstLit Literal            -- ...ditto literal
 157   | SubstExpr                   -- Id maps to an as-yet-unsimplified expression
 158         (TyVarEnv Type)         -- ...hence we need to capture the substitution
 159         (IdEnv SubstInfo)       --    environments too
 160         SimplifiableCoreExpr
 161
 162 type StuffAboutId = (OutId,             -- Always has the same unique as the
 163                                         -- Id that maps to it; but may have better
 164                                         -- IdInfo, and a correctly-substituted type,
 165                                         -- than the occurrences of the Id.  So use
 166                                         -- this to replace occurrences
 167
 168                      BinderInfo,        -- How it occurs
 169                                         -- We keep this info so we can modify it when
 170                                         -- something changes.
 171
 172                      Unfolding)         -- Info about what it is bound to
 173 \end{code}
 174
 175
 176 \begin{code}
 177 nullSimplEnv :: SwitchChecker -> SimplEnv
 178
 179 nullSimplEnv sw_chkr
 180   = SimplEnv sw_chkr useCurrentCostCentre
 181              (emptyTyVarSet, emptyTyVarEnv)
 182              (nullIdEnv, nullIdEnv)
 183              nullConApps
 184
 185 getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv)
 186 getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, id_env)
 187
 188 setTyEnv :: SimplEnv -> SimplTypeEnv -> SimplEnv
 189 setTyEnv (SimplEnv chkr encl_cc _ in_id_env con_apps) ty_env
 190   = SimplEnv chkr encl_cc ty_env in_id_env con_apps
 191
 192 setIdEnv :: SimplEnv -> SimplValEnv -> SimplEnv
 193 setIdEnv (SimplEnv chkr encl_cc ty_env _ con_apps) id_env
 194   = SimplEnv chkr encl_cc ty_env id_env con_apps
 195
 196 setSubstEnvs :: SimplEnv -> TyVarEnv Type -> IdEnv SubstInfo -> SimplEnv
 197 setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
 198              ty_subst id_subst
 199   = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
 200
 201 zapSubstEnvs :: SimplEnv -> SimplEnv
 202 zapSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
 203   = SimplEnv chkr encl_cc (in_scope_tyvars, emptyTyVarEnv) (in_scope_ids, nullIdEnv) con_apps
 204 \end{code}
 205
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsubsection{Command-line switches}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 \begin{code}
 214 getSwitchChecker :: SimplEnv -> SwitchChecker
 215 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
 216
 217 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
 218 switchIsSet (SimplEnv chkr _ _ _ _) switch
 219   = switchIsOn chkr switch
 220
 221 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 222 getSimplIntSwitch chkr switch
 223   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 224
 225         -- Crude, but simple
 226 setCaseScrutinee :: SimplEnv -> SimplEnv
 227 setCaseScrutinee (SimplEnv chkr encl_cc ty_env id_env con_apps)
 228   = SimplEnv chkr' encl_cc ty_env id_env con_apps
 229   where
 230     chkr' SimplCaseScrutinee = SwBool True
 231     chkr' other              = chkr other
 232 \end{code}
 233
 234 @switchOffInlining@ is used to prepare the environment for simplifying
 235 the RHS of an Id that's marked with an INLINE pragma.  It is going to
 236 be inlined wherever they are used, and then all the inlining will take
 237 effect.  Meanwhile, there isn't much point in doing anything to the
 238 as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
 239 inlining!  because
 240         (a) not doing so will inline a worker straight back into its wrapper!
 241
 242 and     (b) Consider the following example
 243                 let f = \pq -> BIG
 244                 in
 245                 let g = \y -> f y y
 246                     {-# INLINE g #-}
 247                 in ...g...g...g...g...g...
 248
 249         Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 250         and thence copied multiple times when g is inlined.
 251
 252         Andy disagrees! Example:
 253                 all xs = foldr (&&) True xs
 254                 any p = all . map p  {-# INLINE any #-}
 255
 256         Problem: any won't get deforested, and so if it's exported and
 257         the importer doesn't use the inlining, (eg passes it as an arg)
 258         then we won't get deforestation at all.
 259         We havn't solved this problem yet!
 260
 261 We prepare the envt by simply modifying the id_env, which has
 262 all the unfolding info. At one point we did it by modifying the chkr so
 263 that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
 264 simplifications happening in the body of the RHS.
 265
 266 \begin{code}
 267 switchOffInlining :: SimplEnv -> SimplEnv
 268 switchOffInlining (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
 269   = SimplEnv chkr encl_cc ty_env (mapUFM forget in_scope_ids, id_subst) nullConApps
 270   where
 271     forget (id, binder_info, rhs_info) = (id, noBinderInfo, NoUnfolding)
 272 \end{code}
 273
 274
 275 %************************************************************************
 276 %*                                                                      *
 277 \subsubsection{The ``enclosing cost-centre''}
 278 %*                                                                      *
 279 %************************************************************************
 280
 281 \begin{code}
 282 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
 283
 284 setEnclosingCC env@(SimplEnv chkr _ ty_env id_env con_apps) encl_cc
 285   | costsAreSubsumed encl_cc
 286   = env
 287   | otherwise
 288   = SimplEnv chkr encl_cc ty_env id_env con_apps
 289
 290 getEnclosingCC :: SimplEnv -> CostCentre
 291 getEnclosingCC (SimplEnv chkr encl_cc ty_env id_env con_apps) = encl_cc
 292 \end{code}
 293
 294 %************************************************************************
 295 %*                                                                      *
 296 \subsubsection{The @TypeEnv@ part}
 297 %*                                                                      *
 298 %************************************************************************
 299
 300 These two "bind" functions extend the tyvar substitution.
 301 They don't affect what tyvars are in scope.
 302
 303 \begin{code}
 304 bindTyVar :: SimplEnv -> TyVar -> Type -> SimplEnv
 305 bindTyVar (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) tyvar ty
 306   = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
 307   where
 308     new_ty_subst = addToTyVarEnv ty_subst tyvar ty
 309
 310 bindTyVars :: SimplEnv -> TyVarEnv Type -> SimplEnv
 311 bindTyVars (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) extra_subst
 312   = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
 313   where
 314     new_ty_subst = ty_subst `plusTyVarEnv` extra_subst
 315 \end{code}
 316
 317 \begin{code}
 318 simplTy (SimplEnv _ _ (_, ty_subst) _ _) ty = returnEager (instantiateTy ty_subst ty)
 319 \end{code}
 320
 321 %************************************************************************
 322 %*                                                                      *
 323 \subsubsection{The ``Id env'' part}
 324 %*                                                                      *
 325 %************************************************************************
 326
 327 notInScope forgets that the specified binder is in scope.
 328 It is used when we decide to bind a let(rec) bound thing to
 329 an atom, *after* the Id has been added to the in-scope mapping by simplBinder.
 330
 331 \begin{code}
 332 notInScope :: SimplEnv -> OutBinder -> SimplEnv
 333 notInScope (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) id
 334   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
 335   where
 336     new_in_scope_ids = delOneFromIdEnv in_scope_ids id
 337 \end{code}
 338
 339 These "bind" functions extend the Id substitution.
 340
 341 \begin{code}
 342 bindIdToAtom :: SimplEnv
 343              -> InBinder
 344              -> OutArg  -- Val args only, please
 345              -> SimplEnv
 346
 347 bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
 348              (in_id,occ_info) atom
 349   = SimplEnv chkr encl_cc ty_env id_env' con_apps
 350   where
 351     id_env' = case atom of
 352                 LitArg lit -> (in_scope_ids, addOneToIdEnv id_subst in_id (SubstLit lit))
 353                 VarArg id  -> (modifyOccInfo in_scope_ids (uniqueOf id) occ_info,
 354                                addOneToIdEnv id_subst in_id (SubstVar id))
 355
 356 bindIdToExpr :: SimplEnv
 357              -> InBinder
 358              -> SimplifiableCoreExpr
 359              -> SimplEnv
 360
 361 bindIdToExpr (SimplEnv chkr encl_cc ty_env@(_, ty_subst) (in_scope_ids, id_subst) con_apps)
 362              (in_id,occ_info) expr
 363   = ASSERT( isOneFunOcc occ_info )      -- Binder occurs just once, safely, so no
 364                                         -- need to adjust occurrence info for RHS,
 365                                         -- unlike bindIdToAtom
 366     SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst') con_apps
 367   where
 368     id_subst' = addOneToIdEnv id_subst in_id (SubstExpr ty_subst id_subst expr)
 369 \end{code}
 370
 371
 372 %************************************************************************
 373 %*                                                                      *
 374 \subsubsection{The @OutIdEnv@}
 375 %*                                                                      *
 376 %************************************************************************
 377
 378 \begin{code}
 379 lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo
 380 lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id
 381
 382 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId, BinderInfo, Unfolding)
 383 lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id
 384
 385 lookupUnfolding :: SimplEnv -> OutId -> Unfolding
 386 lookupUnfolding env id
 387   = case lookupOutIdEnv env id of
 388         Just (_,_,info) -> info
 389         Nothing         -> NoUnfolding
 390
 391 modifyOutEnvItem :: (OutId, BinderInfo, Unfolding)
 392                  -> (OutId, BinderInfo, Unfolding)
 393                  -> (OutId, BinderInfo, Unfolding)
 394 modifyOutEnvItem (id, occ, info1) (_, _, info2)
 395   = case (info1, info2) of
 396                 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
 397                 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
 398                 (_,            NoUnfolding)  -> (id,occ, info1)
 399                 other                        -> (id,occ, info2)
 400 \end{code}
 401
 402
 403 \begin{code}
 404 isEvaluated :: Unfolding -> Bool
 405 isEvaluated (OtherLit _) = True
 406 isEvaluated (OtherCon _) = True
 407 isEvaluated (CoreUnfolding ValueForm _ expr) = True
 408 isEvaluated other = False
 409 \end{code}
 410
 411
 412
 413 \begin{code}
 414 mkSimplUnfoldingGuidance chkr out_id rhs
 415   = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
 416
 417 extendEnvGivenUnfolding :: SimplEnv -> OutId -> BinderInfo -> Unfolding -> SimplEnv
 418 extendEnvGivenUnfolding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
 419                       out_id occ_info rhs_info
 420   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
 421   where
 422     new_in_scope_ids = addToUFM_C modifyOutEnvItem in_scope_ids out_id
 423                                   (out_id, occ_info, rhs_info)
 424 \end{code}
 425
 426
 427 \begin{code}
 428 modifyOccInfo in_scope_ids uniq new_occ
 429   = modifyIdEnv_Directly modify_fn in_scope_ids uniq
 430   where
 431     modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
 432
 433 markDangerousOccs (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) atoms
 434   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
 435   where
 436     new_in_scope_ids = foldl (modifyIdEnv modify_fn) in_scope_ids [v | VarArg v <- atoms]
 437     modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
 438 \end{code}
 439
 440
 441 %************************************************************************
 442 %*                                                                      *
 443 \subsubsection{The @ConAppMap@ type}
 444 %*                                                                      *
 445 %************************************************************************
 446
 447 The @ConAppMap@ maps applications of constructors (to value atoms)
 448 back to an association list that says "if the constructor was applied
 449 to one of these lists-of-Types, then this OutId is your man (in a
 450 non-gender-specific sense)".  I.e., this is a reversed mapping for
 451 (part of) the main OutIdEnv
 452
 453 \begin{code}
 454 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
 455
 456 data UnfoldConApp
 457   = UCA         OutId                   -- data constructor
 458                 [OutArg]                -- *value* arguments; see use below
 459 \end{code}
 460
 461 \begin{code}
 462 nullConApps = emptyFM
 463
 464 extendConApps con_apps id (Con con args)
 465   = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
 466   where
 467     val_args = filter isValArg args             -- Literals and Ids
 468     ty_args  = [ty | TyArg ty <- args]          -- Just types
 469
 470 extendConApps con_apps id other_rhs = con_apps
 471 \end{code}
 472
 473 \begin{code}
 474 lookForConstructor env@(SimplEnv _ _ _ _ con_apps) (Con con args)
 475   | switchIsSet env SimplReuseCon
 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 lookForConstructor env other = Nothing
 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_scope_ids, id_subst) con_apps)
 590                       occ_info out_id rhs
 591   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps
 592   where
 593     new_in_scope_ids | okToInline (whnfOrBottom form)
 594                                   (couldBeSmallEnoughToInline out_id guidance)
 595                                   occ_info
 596                      = env_with_unfolding
 597                      | otherwise
 598                      = in_scope_ids
 599         -- Don't bother to munge 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         -- That's to take account of:
 607         --              let a = \x -> BIG in
 608         --              let b = \f -> f a
 609         --              in ...b...b...b...
 610         -- Here "a" occurs exactly once. "b" simplifies to a small value.
 611         -- So "b" will be inlined at each call site, and there's a good chance
 612         -- that "a" will too.  So we'd better modify "a"s occurrence info to
 613         -- record the fact that it can now occur many times by virtue that "b" can.
 614     env_with_unfolding = _scc_ "eegnr.modify_occ"
 615                          foldl zap env1 (ufmToList fv_occ_info)
 616     zap env (uniq,_)   = modifyOccInfo env uniq occ_info
 617
 618
 619         -- Add an unfolding and rhs_info for the new Id.
 620         -- If the out_id is already in the OutIdEnv (which should be the
 621         -- case because it was put there by simplBinder)
 622         -- then just replace the unfolding, leaving occurrence info alone.
 623     env1                      = _scc_ "eegnr.modify_out"
 624                                 addToUFM_C modifyOutEnvItem in_scope_ids out_id
 625                                            (out_id, occ_info, rhs_info)
 626
 627         -- Occurrence-analyse the RHS
 628         -- The "interesting" free variables we want occurrence info for are those
 629         -- in the OutIdEnv that have only a single occurrence right now.
 630     (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
 631                               occurAnalyseExpr is_interesting rhs_w_cc
 632
 633     is_interesting v        = _scc_ "eegnr.mkidset"
 634                               case lookupIdEnv in_scope_ids v of
 635                                 Just (_, occ, _) -> isOneOcc occ
 636                                 other            -> False
 637
 638         -- Compute unfolding details
 639     rhs_info = CoreUnfolding form guidance template
 640     form     = _scc_ "eegnr.form_sum"
 641                mkFormSummary rhs
 642     guidance = _scc_ "eegnr.guidance"
 643                mkSimplUnfoldingGuidance chkr out_id rhs
 644
 645         -- Attach a cost centre to the RHS if necessary
 646     rhs_w_cc  | isCurrentCostCentre encl_cc
 647               || not (noCostCentreAttached (coreExprCc rhs))
 648               = rhs
 649               | otherwise
 650               = SCC encl_cc rhs
 651 \end{code}