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