ghc/compiler/simplCore/SimplEnv.lhs

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