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