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