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