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