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)
 417                  -> (OutId, BinderInfo, Unfolding)
 418                  -> (OutId, BinderInfo, Unfolding)
 419 modifyOutEnvItem (id, occ, info1) (_, _, info2)
 420   = case (info1, info2) of
 421                 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
 422                 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
 423                 (_,            NoUnfolding)  -> (id,occ, info1)
 424                 other                        -> (id,occ, 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_C modifyOutEnvItem in_scope_ids out_id
 445                                   (out_id, occ_info, rhs_info)
 446 \end{code}
 447
 448
 449 \begin{code}
 450 modifyOccInfo in_scope_ids uniq new_occ
 451   = modifyIdEnv_Directly modify_fn in_scope_ids uniq
 452   where
 453     modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
 454
 455 markDangerousOccs (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) atoms
 456   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
 457   where
 458     new_in_scope_ids = foldl (modifyIdEnv modify_fn) in_scope_ids [v | VarArg v <- atoms]
 459     modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
 460 \end{code}
 461
 462
 463 %************************************************************************
 464 %*                                                                      *
 465 \subsubsection{The @ConAppMap@ type}
 466 %*                                                                      *
 467 %************************************************************************
 468
 469 The @ConAppMap@ maps applications of constructors (to value atoms)
 470 back to an association list that says "if the constructor was applied
 471 to one of these lists-of-Types, then this OutId is your man (in a
 472 non-gender-specific sense)".  I.e., this is a reversed mapping for
 473 (part of) the main OutIdEnv
 474
 475 \begin{code}
 476 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
 477
 478 data UnfoldConApp
 479   = UCA         OutId                   -- data constructor
 480                 [OutArg]                -- *value* arguments; see use below
 481 \end{code}
 482
 483 \begin{code}
 484 nullConApps = emptyFM
 485
 486 extendConApps con_apps id (Con con args)
 487   = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
 488   where
 489     val_args = filter isValArg args             -- Literals and Ids
 490     ty_args  = [ty | TyArg ty <- args]          -- Just types
 491
 492 extendConApps con_apps id other_rhs = con_apps
 493 \end{code}
 494
 495 \begin{code}
 496 lookForConstructor env@(SimplEnv _ _ _ _ con_apps) (Con con args)
 497   | switchIsSet env SimplReuseCon
 498   = case lookupFM con_apps (UCA con val_args) of
 499         Nothing     -> Nothing
 500
 501         Just assocs -> case [id | (tys, id) <- assocs,
 502                                   and (zipWith (==) tys ty_args)]
 503                        of
 504                           []     -> Nothing
 505                           (id:_) -> Just id
 506   where
 507     val_args = filter isValArg args             -- Literals and Ids
 508     ty_args  = [ty | TyArg ty <- args]          -- Just types
 509
 510 lookForConstructor env other = Nothing
 511 \end{code}
 512
 513 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
 514 for nullary constructors, but now we only do constructor re-use in
 515 let-bindings the special case isn't necessary any more.
 516
 517 \begin{verbatim}
 518   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 519         -- let
 520         --        a = leInt#! p q
 521         -- in
 522         -- case a of
 523         --    True  -> ...
 524         --    False -> False
 525         --
 526         -- Here the False in the second case will get replace by "a", hardly
 527         -- a good idea
 528     Nothing
 529 \end{verbatim}
 530
 531
 532 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 533 it, so we can use it for a @FiniteMap@ key.
 534
 535 \begin{code}
 536 instance Eq  UnfoldConApp where
 537     a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
 538     a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }
 539
 540 instance Ord UnfoldConApp where
 541     a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
 542     a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
 543     a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
 544     a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
 545     compare a b = cmp_app a b
 546
 547 cmp_app (UCA c1 as1) (UCA c2 as2)
 548   = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2
 549   where
 550     -- ToDo: make an "instance Ord CoreArg"???
 551
 552     cmp_arg (VarArg   x) (VarArg   y) = x `compare` y
 553     cmp_arg (LitArg   x) (LitArg   y) = x `compare` y
 554     cmp_arg (TyArg    x) (TyArg    y) = panic "SimplEnv.cmp_app:TyArgs"
 555     cmp_arg x y
 556       | tag x _LT_ tag y = LT
 557       | otherwise        = GT
 558       where
 559         tag (VarArg   _) = ILIT(1)
 560         tag (LitArg   _) = ILIT(2)
 561         tag (TyArg    _) = panic# "SimplEnv.cmp_app:TyArg"
 562 \end{code}
 563
 564
 565 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 566 of a new binding.  There is a horrid case we have to take care about,
 567 due to Andr\'e Santos:
 568 @
 569     type Array_type b   = Array Int b;
 570     type Descr_type     = (Int,Int);
 571
 572     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 573     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 574
 575     f_iaamain a_xs=
 576         let {
 577             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 578             f_aareorder a_index a_ar=
 579                 let {
 580                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 581                  } in  tabulate f_aareorder' (bounds a_ar);
 582             r_index=tabulate ((+) 1) (1,1);
 583             arr    = listArray (1,1) a_xs;
 584             arg    = f_aareorder r_index arr
 585          } in  elems arg
 586 @
 587 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 588 @
 589         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 590                in tabulate f_aareorder' (bounds arr)
 591 @
 592 Note that r_index is not inlined, because it was bound to a_index which
 593 occurs inside a lambda.
 594
 595 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 596 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 597 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 598 will get inlined inside the lambda.  AARGH.
 599
 600 Solution: when we occurrence-analyse the new RHS we have to go back
 601 and modify the info recorded in the UnfoldEnv for the free vars
 602 of the RHS.  In the example we'd go back and record that r_index is now used
 603 inside a lambda.
 604
 605 \begin{code}
 606 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 607 extendEnvGivenNewRhs env out_id rhs
 608   = extendEnvGivenBinding env noBinderInfo out_id rhs
 609
 610 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
 611 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
 612                       occ_info out_id rhs
 613   = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps
 614   where
 615     new_in_scope_ids | okToInline out_id
 616                                   (whnfOrBottom form)
 617                                   (couldBeSmallEnoughToInline out_id guidance)
 618                                   occ_info
 619                      = env_with_unfolding
 620                      | otherwise
 621                      = in_scope_ids
 622         -- Don't bother to munge the OutIdEnv unless there is some possibility
 623         -- that the thing might be inlined.  We check this by calling okToInline suitably.
 624
 625     new_con_apps = _scc_ "eegnr.conapps"
 626                    extendConApps con_apps out_id rhs
 627
 628         -- Modify the occ info for rhs's interesting free variables.
 629         -- That's to take account of:
 630         --              let a = \x -> BIG in
 631         --              let b = \f -> f a
 632         --              in ...b...b...b...
 633         -- Here "a" occurs exactly once. "b" simplifies to a small value.
 634         -- So "b" will be inlined at each call site, and there's a good chance
 635         -- that "a" will too.  So we'd better modify "a"s occurrence info to
 636         -- record the fact that it can now occur many times by virtue that "b" can.
 637     env_with_unfolding = _scc_ "eegnr.modify_occ"
 638                          foldl zap env1 (ufmToList fv_occ_info)
 639     zap env (uniq,_)   = modifyOccInfo env uniq occ_info
 640
 641
 642         -- Add an unfolding and rhs_info for the new Id.
 643         -- If the out_id is already in the OutIdEnv (which should be the
 644         -- case because it was put there by simplBinder)
 645         -- then just replace the unfolding, leaving occurrence info alone.
 646     env1                      = _scc_ "eegnr.modify_out"
 647                                 addToUFM_C modifyOutEnvItem in_scope_ids out_id
 648                                            (out_id, occ_info, rhs_info)
 649
 650         -- Occurrence-analyse the RHS
 651         -- The "interesting" free variables we want occurrence info for are those
 652         -- in the OutIdEnv that have only a single occurrence right now.
 653     (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
 654                               occurAnalyseExpr is_interesting rhs_w_cc
 655
 656     is_interesting v        = _scc_ "eegnr.mkidset"
 657                               case lookupIdEnv in_scope_ids v of
 658                                 Just (_, occ, _) -> isOneOcc occ
 659                                 other            -> False
 660
 661         -- Compute unfolding details
 662     rhs_info = CoreUnfolding form guidance template
 663     form     = _scc_ "eegnr.form_sum"
 664                mkFormSummary rhs
 665     guidance = _scc_ "eegnr.guidance"
 666                calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
 667
 668         -- Attach a cost centre to the RHS if necessary
 669     rhs_w_cc  | currentOrSubsumedCosts encl_cc
 670               || not (noCostCentreAttached (coreExprCc rhs))
 671               = rhs
 672               | otherwise
 673               = Note (SCC encl_cc) rhs
 674 \end{code}