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,
  10
  11         bindTyVar, bindTyVars, simplTy,
  12
  13         lookupIdSubst, lookupOutIdEnv,
  14
  15         bindIdToAtom, bindIdToExpr,
  16
  17         markDangerousOccs,
  18         lookupRhsInfo, isEvaluated,
  19         extendEnvGivenBinding, extendEnvGivenNewRhs,
  20         extendEnvGivenRhsInfo,
  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         RhsInfo(..),
  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(..), SimpleUnfolding(..), FormSummary(..),
  54                           calcUnfoldingGuidance )
  55 import CoreUtils        ( coreExprCc )
  56 import CostCentre       ( CostCentre, subsumedCosts, 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{-instances-} )
  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   = SubstArg OutArg     -- The Id maps to an already-substituted atom
 156   | SubstExpr                   -- Id maps to an as-yet-unsimplified expression
 157         (TyVarEnv Type)         -- ...hence we need to capture the substitution
 158         (IdEnv SubstInfo)       --    environments too
 159         SimplifiableCoreExpr
 160
 161 type StuffAboutId = (OutId,             -- Always has the same unique as the
 162                                         -- Id that maps to it; but may have better
 163                                         -- IdInfo, and a correctly-substituted type,
 164                                         -- than the occurrences of the Id.  So use
 165                                         -- this to replace occurrences
 166
 167                      BinderInfo,        -- How it occurs
 168                                         -- We keep this info so we can modify it when
 169                                         -- something changes.
 170
 171                      RhsInfo)           -- Info about what it is bound to
 172 \end{code}
 173
 174 The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
 175
 176 \begin{code}
 177 data RhsInfo = NoRhsInfo
 178              | OtherLit [Literal]               -- It ain't one of these
 179              | OtherCon [Id]                    -- It ain't one of these
 180              | OutUnfolding CostCentre
 181                             SimpleUnfolding     -- Already-simplified unfolding
 182 \end{code}
 183
 184
 185 \begin{code}
 186 nullSimplEnv :: SwitchChecker -> SimplEnv
 187
 188 nullSimplEnv sw_chkr
 189   = SimplEnv sw_chkr subsumedCosts (emptyTyVarSet, emptyTyVarEnv) (nullIdEnv, nullIdEnv) nullConApps
 190
 191 getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv)
 192 getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, id_env)
 193
 194 setTyEnv :: SimplEnv -> SimplTypeEnv -> SimplEnv
 195 setTyEnv (SimplEnv chkr encl_cc _ in_id_env con_apps) ty_env
 196   = SimplEnv chkr encl_cc ty_env in_id_env con_apps
 197
 198 setIdEnv :: SimplEnv -> SimplValEnv -> SimplEnv
 199 setIdEnv (SimplEnv chkr encl_cc ty_env _ con_apps) id_env
 200   = SimplEnv chkr encl_cc ty_env id_env con_apps
 201
 202 setSubstEnvs :: SimplEnv -> TyVarEnv Type -> IdEnv SubstInfo -> SimplEnv
 203 setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
 204              ty_subst id_subst
 205   = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
 206 \end{code}
 207
 208
 209 %************************************************************************
 210 %*                                                                      *
 211 \subsubsection{Command-line switches}
 212 %*                                                                      *
 213 %************************************************************************
 214
 215 \begin{code}
 216 getSwitchChecker :: SimplEnv -> SwitchChecker
 217 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
 218
 219 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
 220 switchIsSet (SimplEnv chkr _ _ _ _) switch
 221   = switchIsOn chkr switch
 222
 223 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 224 getSimplIntSwitch chkr switch
 225   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 226
 227         -- Crude, but simple
 228 setCaseScrutinee :: SimplEnv -> SimplEnv
 229 setCaseScrutinee (SimplEnv chkr encl_cc ty_env id_env con_apps)
 230   = SimplEnv chkr' encl_cc ty_env id_env con_apps
 231   where
 232     chkr' SimplCaseScrutinee = SwBool True
 233     chkr' other              = chkr other
 234 \end{code}
 235
 236 @switchOffInlining@ is used to prepare the environment for simplifying
 237 the RHS of an Id that's marked with an INLINE pragma.  It is going to
 238 be inlined wherever they are used, and then all the inlining will take
 239 effect.  Meanwhile, there isn't much point in doing anything to the
 240 as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
 241 inlining!  because
 242         (a) not doing so will inline a worker straight back into its wrapper!
 243
 244 and     (b) Consider the following example
 245                 let f = \pq -> BIG
 246                 in
 247                 let g = \y -> f y y
 248                     {-# INLINE g #-}
 249                 in ...g...g...g...g...g...
 250
 251         Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 252         and thence copied multiple times when g is inlined.
 253
 254         Andy disagrees! Example:
 255                 all xs = foldr (&&) True xs
 256                 any p = all . map p  {-# INLINE any #-}
 257
 258         Problem: any won't get deforested, and so if it's exported and
 259         the importer doesn't use the inlining, (eg passes it as an arg)
 260         then we won't get deforestation at all.
 261         We havn't solved this problem yet!
 262
 263 We prepare the envt by simply modifying the id_env, which has
 264 all the unfolding info. At one point we did it by modifying the chkr so
 265 that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
 266 simplifications happening in the body of the RHS.
 267
 268 \begin{code}
 269 switchOffInlining :: SimplEnv -> SimplEnv
 270 switchOffInlining (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
 271   = SimplEnv chkr encl_cc ty_env (mapUFM forget in_scope_ids, id_subst) nullConApps
 272   where
 273     forget (id, binder_info, rhs_info) = (id, noBinderInfo, NoRhsInfo)
 274 \end{code}
 275
 276
 277 %************************************************************************
 278 %*                                                                      *
 279 \subsubsection{The ``enclosing cost-centre''}
 280 %*                                                                      *
 281 %************************************************************************
 282
 283 \begin{code}
 284 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
 285
 286 setEnclosingCC env@(SimplEnv chkr _ ty_env id_env con_apps) encl_cc
 287   | costsAreSubsumed encl_cc
 288   = env
 289   | otherwise
 290   = SimplEnv chkr encl_cc ty_env id_env con_apps
 291
 292 getEnclosingCC :: SimplEnv -> CostCentre
 293 getEnclosingCC (SimplEnv chkr encl_cc ty_env id_env con_apps) = encl_cc
 294 \end{code}
 295
 296 %************************************************************************
 297 %*                                                                      *
 298 \subsubsection{The @TypeEnv@ part}
 299 %*                                                                      *
 300 %************************************************************************
 301
 302 These two "bind" functions extend the tyvar substitution.
 303 They don't affect what tyvars are in scope.
 304
 305 \begin{code}
 306 bindTyVar :: SimplEnv -> TyVar -> Type -> SimplEnv
 307 bindTyVar (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) tyvar ty
 308   = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
 309   where
 310     new_ty_subst = addToTyVarEnv ty_subst tyvar ty
 311
 312 bindTyVars :: SimplEnv -> TyVarEnv Type -> SimplEnv
 313 bindTyVars (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) extra_subst
 314   = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
 315   where
 316     new_ty_subst = ty_subst `plusTyVarEnv` extra_subst
 317 \end{code}
 318
 319 \begin{code}
 320 simplTy (SimplEnv _ _ (_, ty_subst) _ _) ty = returnEager (instantiateTy ty_subst ty)
 321 \end{code}
 322
 323 %************************************************************************
 324 %*                                                                      *
 325 \subsubsection{The ``Id env'' part}
 326 %*                                                                      *
 327 %************************************************************************
 328
 329 notInScope forgets that the specified binder is in scope.
 330 It is used when we decide to bind a let(rec) bound thing to
 331 an atom, *after* the Id has been added to the in-scope mapping by simplBinder.
 332
 333 \begin{code}
 334 notInScope :: SimplEnv -> OutBinder -> SimplEnv
 335 notInScope (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) id
 336   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
 337   where
 338     new_in_scope_ids = delOneFromIdEnv in_scope_ids id
 339 \end{code}
 340
 341 These "bind" functions extend the Id substitution.
 342
 343 \begin{code}
 344 bindIdToAtom :: SimplEnv
 345              -> InBinder
 346              -> OutArg  -- Val args only, please
 347              -> SimplEnv
 348
 349 bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
 350              (in_id,occ_info) atom
 351   = SimplEnv chkr encl_cc ty_env (in_scope_ids', id_subst') con_apps
 352   where
 353     id_subst'     = addOneToIdEnv id_subst in_id (SubstArg atom)
 354     in_scope_ids' =  case atom of
 355                         LitArg _      -> in_scope_ids
 356                         VarArg out_id -> modifyOccInfo in_scope_ids (uniqueOf out_id) occ_info
 357
 358 bindIdToExpr :: SimplEnv
 359              -> InBinder
 360              -> SimplifiableCoreExpr
 361              -> SimplEnv
 362
 363 bindIdToExpr (SimplEnv chkr encl_cc ty_env@(_, ty_subst) (in_scope_ids, id_subst) con_apps)
 364              (in_id,occ_info) expr
 365   = ASSERT( isOneFunOcc occ_info )      -- Binder occurs just once, safely, so no
 366                                         -- need to adjust occurrence info for RHS,
 367                                         -- unlike bindIdToAtom
 368     SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst') con_apps
 369   where
 370     id_subst' = addOneToIdEnv id_subst in_id (SubstExpr ty_subst id_subst expr)
 371 \end{code}
 372
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsubsection{The @OutIdEnv@}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 \begin{code}
 381 lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo
 382 lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id
 383
 384 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
 385 lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id
 386
 387 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
 388 lookupRhsInfo env id
 389   = case lookupOutIdEnv env id of
 390         Just (_,_,info) -> info
 391         Nothing         -> NoRhsInfo
 392
 393 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
 394                  -> (OutId, BinderInfo, RhsInfo)
 395                  -> (OutId, BinderInfo, RhsInfo)
 396 modifyOutEnvItem (id, occ, info1) (_, _, info2)
 397   = case (info1, info2) of
 398                 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
 399                 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
 400                 (_,            NoRhsInfo)    -> (id,occ, info1)
 401                 other                        -> (id,occ, info2)
 402 \end{code}
 403
 404
 405 \begin{code}
 406 isEvaluated :: RhsInfo -> Bool
 407 isEvaluated (OtherLit _) = True
 408 isEvaluated (OtherCon _) = True
 409 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
 410 isEvaluated other = False
 411 \end{code}
 412
 413
 414
 415 \begin{code}
 416 mkSimplUnfoldingGuidance chkr out_id rhs
 417   = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
 418
 419 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
 420 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
 421                       out_id occ_info rhs_info
 422   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
 423   where
 424     new_in_scope_ids = addToUFM_C modifyOutEnvItem in_scope_ids out_id
 425                                   (out_id, occ_info, rhs_info)
 426 \end{code}
 427
 428
 429 \begin{code}
 430 modifyOccInfo in_scope_ids uniq new_occ
 431   = modifyIdEnv_Directly modify_fn in_scope_ids uniq
 432   where
 433     modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
 434
 435 markDangerousOccs (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) atoms
 436   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
 437   where
 438     new_in_scope_ids = foldl (modifyIdEnv modify_fn) in_scope_ids [v | VarArg v <- atoms]
 439     modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
 440 \end{code}
 441
 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 env@(SimplEnv _ _ _ _ con_apps) (Con con args)
 477   | switchIsSet env SimplReuseCon
 478   = case lookupFM con_apps (UCA con val_args) of
 479         Nothing     -> Nothing
 480
 481         Just assocs -> case [id | (tys, id) <- assocs,
 482                                   and (zipWith (==) tys ty_args)]
 483                        of
 484                           []     -> Nothing
 485                           (id:_) -> Just id
 486   where
 487     val_args = filter isValArg args             -- Literals and Ids
 488     ty_args  = [ty | TyArg ty <- args]          -- Just types
 489
 490 lookForConstructor env other = Nothing
 491 \end{code}
 492
 493 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
 494 for nullary constructors, but now we only do constructor re-use in
 495 let-bindings the special case isn't necessary any more.
 496
 497 \begin{verbatim}
 498   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 499         -- let
 500         --        a = leInt#! p q
 501         -- in
 502         -- case a of
 503         --    True  -> ...
 504         --    False -> False
 505         --
 506         -- Here the False in the second case will get replace by "a", hardly
 507         -- a good idea
 508     Nothing
 509 \end{verbatim}
 510
 511
 512 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 513 it, so we can use it for a @FiniteMap@ key.
 514
 515 \begin{code}
 516 instance Eq  UnfoldConApp where
 517     a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
 518     a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }
 519
 520 instance Ord UnfoldConApp where
 521     a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
 522     a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
 523     a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
 524     a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
 525     compare a b = cmp_app a b
 526
 527 cmp_app (UCA c1 as1) (UCA c2 as2)
 528   = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2
 529   where
 530     -- ToDo: make an "instance Ord CoreArg"???
 531
 532     cmp_arg (VarArg   x) (VarArg   y) = x `compare` y
 533     cmp_arg (LitArg   x) (LitArg   y) = x `compare` y
 534     cmp_arg (TyArg    x) (TyArg    y) = panic "SimplEnv.cmp_app:TyArgs"
 535     cmp_arg x y
 536       | tag x _LT_ tag y = LT
 537       | otherwise        = GT
 538       where
 539         tag (VarArg   _) = ILIT(1)
 540         tag (LitArg   _) = ILIT(2)
 541         tag (TyArg    _) = panic# "SimplEnv.cmp_app:TyArg"
 542 \end{code}
 543
 544
 545 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 546 of a new binding.  There is a horrid case we have to take care about,
 547 due to Andr\'e Santos:
 548 @
 549     type Array_type b   = Array Int b;
 550     type Descr_type     = (Int,Int);
 551
 552     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 553     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 554
 555     f_iaamain a_xs=
 556         let {
 557             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 558             f_aareorder a_index a_ar=
 559                 let {
 560                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 561                  } in  tabulate f_aareorder' (bounds a_ar);
 562             r_index=tabulate ((+) 1) (1,1);
 563             arr    = listArray (1,1) a_xs;
 564             arg    = f_aareorder r_index arr
 565          } in  elems arg
 566 @
 567 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 568 @
 569         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 570                in tabulate f_aareorder' (bounds arr)
 571 @
 572 Note that r_index is not inlined, because it was bound to a_index which
 573 occurs inside a lambda.
 574
 575 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 576 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 577 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 578 will get inlined inside the lambda.  AARGH.
 579
 580 Solution: when we occurrence-analyse the new RHS we have to go back
 581 and modify the info recorded in the UnfoldEnv for the free vars
 582 of the RHS.  In the example we'd go back and record that r_index is now used
 583 inside a lambda.
 584
 585 \begin{code}
 586 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 587 extendEnvGivenNewRhs env out_id rhs
 588   = extendEnvGivenBinding env noBinderInfo out_id rhs
 589
 590 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
 591 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
 592                       occ_info out_id rhs
 593   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps
 594   where
 595     new_in_scope_ids | okToInline (whnfOrBottom form)
 596                                   (couldBeSmallEnoughToInline out_id guidance)
 597                                   occ_info
 598                      = env_with_unfolding
 599                      | otherwise
 600                      = in_scope_ids
 601         -- Don't bother to munge the OutIdEnv unless there is some possibility
 602         -- that the thing might be inlined.  We check this by calling okToInline suitably.
 603
 604     new_con_apps = _scc_ "eegnr.conapps"
 605                    extendConApps con_apps out_id rhs
 606
 607         -- Modify the occ info for rhs's interesting free variables.
 608         -- That's to take account of:
 609         --              let a = \x -> BIG in
 610         --              let b = \f -> f a
 611         --              in ...b...b...b...
 612         -- Here "a" occurs exactly once. "b" simplifies to a small value.
 613         -- So "b" will be inlined at each call site, and there's a good chance
 614         -- that "a" will too.  So we'd better modify "a"s occurrence info to
 615         -- record the fact that it can now occur many times by virtue that "b" can.
 616     env_with_unfolding = _scc_ "eegnr.modify_occ"
 617                          foldl zap env1 (ufmToList fv_occ_info)
 618     zap env (uniq,_)   = modifyOccInfo env uniq occ_info
 619
 620
 621         -- Add an unfolding and rhs_info for the new Id.
 622         -- If the out_id is already in the OutIdEnv (which should be the
 623         -- case because it was put there by simplBinder)
 624         -- then just replace the unfolding, leaving occurrence info alone.
 625     env1                      = _scc_ "eegnr.modify_out"
 626                                 addToUFM_C modifyOutEnvItem in_scope_ids out_id
 627                                            (out_id, occ_info, rhs_info)
 628
 629         -- Occurrence-analyse the RHS
 630         -- The "interesting" free variables we want occurrence info for are those
 631         -- in the OutIdEnv that have only a single occurrence right now.
 632     (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
 633                               occurAnalyseExpr is_interesting rhs
 634
 635     is_interesting v        = _scc_ "eegnr.mkidset"
 636                               case lookupIdEnv in_scope_ids v of
 637                                 Just (_, occ, _) -> isOneOcc occ
 638                                 other            -> False
 639
 640         -- Compute unfolding details
 641     rhs_info = OutUnfolding unf_cc (SimpleUnfolding form guidance template)
 642     form     = _scc_ "eegnr.form_sum"
 643                mkFormSummary rhs
 644     guidance = _scc_ "eegnr.guidance"
 645                mkSimplUnfoldingGuidance chkr out_id rhs
 646
 647         -- Compute cost centre for thing
 648     unf_cc  | noCostCentreAttached expr_cc = encl_cc
 649             | otherwise                    = expr_cc
 650             where
 651               expr_cc =  coreExprCc rhs
 652 \end{code}