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 env@(SimplEnv _ _ _ _ _ con_apps) (Con con args)
 476   | switchIsSet env SimplReuseCon
 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 lookForConstructor env other = Nothing
 490 \end{code}
 491
 492 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
 493 for nullary constructors, but now we only do constructor re-use in
 494 let-bindings the special case isn't necessary any more.
 495
 496 \begin{verbatim}
 497   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 498         -- let
 499         --        a = leInt#! p q
 500         -- in
 501         -- case a of
 502         --    True  -> ...
 503         --    False -> False
 504         --
 505         -- Here the False in the second case will get replace by "a", hardly
 506         -- a good idea
 507     Nothing
 508 \end{verbatim}
 509
 510
 511 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 512 it, so we can use it for a @FiniteMap@ key.
 513
 514 \begin{code}
 515 instance Eq  UnfoldConApp where
 516     a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
 517     a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }
 518
 519 instance Ord UnfoldConApp where
 520     a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
 521     a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
 522     a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
 523     a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
 524     compare a b = cmp_app a b
 525
 526 cmp_app (UCA c1 as1) (UCA c2 as2)
 527   = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2
 528   where
 529     -- ToDo: make an "instance Ord CoreArg"???
 530
 531     cmp_arg (VarArg   x) (VarArg   y) = x `compare` y
 532     cmp_arg (LitArg   x) (LitArg   y) = x `compare` y
 533     cmp_arg (TyArg    x) (TyArg    y) = panic "SimplEnv.cmp_app:TyArgs"
 534     cmp_arg x y
 535       | tag x _LT_ tag y = LT
 536       | otherwise        = GT
 537       where
 538         tag (VarArg   _) = ILIT(1)
 539         tag (LitArg   _) = ILIT(2)
 540         tag (TyArg    _) = panic# "SimplEnv.cmp_app:TyArg"
 541 \end{code}
 542
 543
 544 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 545 of a new binding.  There is a horrid case we have to take care about,
 546 due to Andr\'e Santos:
 547 @
 548     type Array_type b   = Array Int b;
 549     type Descr_type     = (Int,Int);
 550
 551     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 552     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 553
 554     f_iaamain a_xs=
 555         let {
 556             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 557             f_aareorder a_index a_ar=
 558                 let {
 559                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 560                  } in  tabulate f_aareorder' (bounds a_ar);
 561             r_index=tabulate ((+) 1) (1,1);
 562             arr    = listArray (1,1) a_xs;
 563             arg    = f_aareorder r_index arr
 564          } in  elems arg
 565 @
 566 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 567 @
 568         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 569                in tabulate f_aareorder' (bounds arr)
 570 @
 571 Note that r_index is not inlined, because it was bound to a_index which
 572 occurs inside a lambda.
 573
 574 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 575 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 576 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 577 will get inlined inside the lambda.  AARGH.
 578
 579 Solution: when we occurrence-analyse the new RHS we have to go back
 580 and modify the info recorded in the UnfoldEnv for the free vars
 581 of the RHS.  In the example we'd go back and record that r_index is now used
 582 inside a lambda.
 583
 584 \begin{code}
 585 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 586 extendEnvGivenNewRhs env out_id rhs
 587   = extendEnvGivenBinding env noBinderInfo out_id rhs
 588
 589 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
 590 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 591                       occ_info out_id rhs
 592   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
 593   where
 594     new_out_id_env | okToInline (whnfOrBottom form)
 595                                 (couldBeSmallEnoughToInline out_id guidance)
 596                                 occ_info
 597                    = out_id_env_with_unfolding
 598                    | otherwise
 599                    = out_id_env
 600         -- Don't bother to extend the OutIdEnv unless there is some possibility
 601         -- that the thing might be inlined.  We check this by calling okToInline suitably.
 602
 603     new_con_apps = _scc_ "eegnr.conapps"
 604                    extendConApps con_apps out_id rhs
 605
 606         -- Modify the occ info for rhs's interesting free variables.
 607     out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
 608                                 foldl modifyOccInfo env1 full_fv_occ_info
 609                 -- NB: full_fv_occ_info *combines* the occurrence of the current binder
 610                 -- with the occurrences of its RHS's free variables.  That's to take
 611                 -- account of:
 612                 --              let a = \x -> BIG in
 613                 --              let b = \f -> f a
 614                 --              in ...b...b...b...
 615                 -- Here "a" occurs exactly once. "b" simplifies to a small value.
 616                 -- So "b" will be inlined at each call site, and there's a good chance
 617                 -- that "a" will too.  So we'd better modify "a"s occurrence info to
 618                 -- record the fact that it can now occur many times by virtue that "b" can.
 619
 620     full_fv_occ_info          = _scc_ "eegnr.full_fv"
 621                                 [ (uniq, fv_occ `andBinderInfo` occ_info)
 622                                 | (uniq, fv_occ) <- ufmToList fv_occ_info
 623                                 ]
 624
 625         -- Add an unfolding and rhs_info for the new Id.
 626         -- If the out_id is already in the OutIdEnv (which can happen if
 627         -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
 628         -- then just replace the unfolding, leaving occurrence info alone.
 629     env1                      = _scc_ "eegnr.modify_out"
 630                                 addToUFM_C modifyOutEnvItem out_id_env out_id
 631                                            (out_id, occ_info, rhs_info)
 632
 633         -- Occurrence-analyse the RHS
 634         -- The "interesting" free variables we want occurrence info for are those
 635         -- in the OutIdEnv that have only a single occurrence right now.
 636     (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
 637                               occurAnalyseExpr is_interesting rhs
 638
 639     is_interesting v        = _scc_ "eegnr.mkidset"
 640                               case lookupIdEnv out_id_env v of
 641                                 Just (_, occ, _) -> isOneOcc occ
 642                                 other            -> False
 643
 644         -- Compute unfolding details
 645     rhs_info = OutUnfolding unf_cc (SimpleUnfolding form guidance template)
 646     form     = _scc_ "eegnr.form_sum"
 647                mkFormSummary rhs
 648     guidance = _scc_ "eegnr.guidance"
 649                mkSimplUnfoldingGuidance chkr out_id rhs
 650
 651         -- Compute cost centre for thing
 652     unf_cc  | noCostCentreAttached expr_cc = encl_cc
 653             | otherwise                    = expr_cc
 654             where
 655               expr_cc =  coreExprCc rhs
 656 \end{code}