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