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,
  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_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 SimplEnv             -- Un-simplified unfolding
 374                            SimpleUnfolding      -- (need to snag envts therefore)
 375
 376              | OutUnfolding CostCentre
 377                             SimpleUnfolding     -- Already-simplified unfolding
 378
 379 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
 380 lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
 381
 382 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
 383 lookupRhsInfo env id
 384   = case lookupOutIdEnv env id of
 385         Just (_,_,info) -> info
 386         Nothing         -> NoRhsInfo
 387
 388 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
 389                  -> (OutId, BinderInfo, RhsInfo)
 390                  -> (OutId, BinderInfo, RhsInfo)
 391 modifyOutEnvItem (id, occ, info1) (_, _, info2)
 392   = case (info1, info2) of
 393                 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
 394                 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
 395                 (_,            NoRhsInfo)    -> (id,occ, info1)
 396                 other                        -> (id,occ, info2)
 397 \end{code}
 398
 399
 400 \begin{code}
 401 isEvaluated :: RhsInfo -> Bool
 402 isEvaluated (OtherLit _) = True
 403 isEvaluated (OtherCon _) = True
 404 isEvaluated (InUnfolding _  (SimpleUnfolding ValueForm _ expr)) = 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
 440 %************************************************************************
 441 %*                                                                      *
 442 \subsubsection{The @ConAppMap@ type}
 443 %*                                                                      *
 444 %************************************************************************
 445
 446 The @ConAppMap@ maps applications of constructors (to value atoms)
 447 back to an association list that says "if the constructor was applied
 448 to one of these lists-of-Types, then this OutId is your man (in a
 449 non-gender-specific sense)".  I.e., this is a reversed mapping for
 450 (part of) the main OutIdEnv
 451
 452 \begin{code}
 453 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
 454
 455 data UnfoldConApp
 456   = UCA         OutId                   -- data constructor
 457                 [OutArg]                -- *value* arguments; see use below
 458 \end{code}
 459
 460 \begin{code}
 461 nullConApps = emptyFM
 462
 463 extendConApps con_apps id (Con con args)
 464   = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
 465   where
 466     val_args = filter isValArg args             -- Literals and Ids
 467     ty_args  = [ty | TyArg ty <- args]          -- Just types
 468
 469 extendConApps con_apps id other_rhs = con_apps
 470 \end{code}
 471
 472 \begin{code}
 473 lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
 474   = case lookupFM con_apps (UCA con val_args) of
 475         Nothing     -> Nothing
 476
 477         Just assocs -> case [id | (tys, id) <- assocs,
 478                                   and (zipWith eqTy tys ty_args)]
 479                        of
 480                           []     -> Nothing
 481                           (id:_) -> Just id
 482   where
 483     val_args = filter isValArg args             -- Literals and Ids
 484     ty_args  = [ty | TyArg ty <- args]          -- Just types
 485
 486 \end{code}
 487
 488 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
 489 for nullary constructors, but now we only do constructor re-use in
 490 let-bindings the special case isn't necessary any more.
 491
 492 \begin{verbatim}
 493   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 494         -- let
 495         --        a = leInt#! p q
 496         -- in
 497         -- case a of
 498         --    True  -> ...
 499         --    False -> False
 500         --
 501         -- Here the False in the second case will get replace by "a", hardly
 502         -- a good idea
 503     Nothing
 504 \end{verbatim}
 505
 506
 507 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 508 it, so we can use it for a @FiniteMap@ key.
 509
 510 \begin{code}
 511 instance Eq  UnfoldConApp where
 512     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
 513     a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
 514
 515 instance Ord UnfoldConApp where
 516     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 517     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 518     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 519     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 520     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 521
 522 instance Ord3 UnfoldConApp where
 523     cmp = cmp_app
 524
 525 cmp_app (UCA c1 as1) (UCA c2 as2)
 526   = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
 527   where
 528     -- ToDo: make an "instance Ord3 CoreArg"???
 529
 530     cmp_arg (VarArg   x) (VarArg   y) = x `cmp` y
 531     cmp_arg (LitArg   x) (LitArg   y) = x `cmp` y
 532     cmp_arg (TyArg    x) (TyArg    y) = panic# "SimplEnv.cmp_app:TyArgs"
 533     cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
 534     cmp_arg x y
 535       | tag x _LT_ tag y = LT_
 536       | otherwise        = GT_
 537       where
 538         tag (VarArg   _) = ILIT(1)
 539         tag (LitArg   _) = ILIT(2)
 540         tag (TyArg    _) = panic# "SimplEnv.cmp_app:TyArg"
 541         tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
 542 \end{code}
 543
 544
 545
 546
 547
 548 ============================  OLD ================================
 549         This version was used when we use the *simplified* RHS of a
 550         let as the thing's unfolding.  The has the nasty property described
 551         in the following comments.  Much worse, it can fail to terminate
 552         on recursive things.  Consider
 553
 554                 letrec f = \x -> let z = f x' in ...
 555
 556                 in
 557                 let n = f y
 558                 in
 559                 case n of { ... }
 560
 561         If we bind n to its *simplified* RHS, we then *re-simplify* it when
 562         we inline n.  Then we may well inline f; and then the same thing
 563         happens with z!
 564
 565
 566 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 567 of a new binding.  There is a horrid case we have to take care about,
 568 due to Andr\'e Santos:
 569 @
 570     type Array_type b   = Array Int b;
 571     type Descr_type     = (Int,Int);
 572
 573     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 574     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 575
 576     f_iaamain a_xs=
 577         let {
 578             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 579             f_aareorder a_index a_ar=
 580                 let {
 581                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 582                  } in  tabulate f_aareorder' (bounds a_ar);
 583             r_index=tabulate ((+) 1) (1,1);
 584             arr    = listArray (1,1) a_xs;
 585             arg    = f_aareorder r_index arr
 586          } in  elems arg
 587 @
 588 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 589 @
 590         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 591                in tabulate f_aareorder' (bounds arr)
 592 @
 593 Note that r_index is not inlined, because it was bound to a_index which
 594 occurs inside a lambda.
 595
 596 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 597 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 598 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 599 will get inlined inside the lambda.  AARGH.
 600
 601 Solution: when we occurrence-analyse the new RHS we have to go back
 602 and modify the info recorded in the UnfoldEnv for the free vars
 603 of the RHS.  In the example we'd go back and record that r_index is now used
 604 inside a lambda.
 605
 606 \begin{code}
 607 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 608 extendEnvGivenNewRhs env out_id rhs
 609   = extendEnvGivenBinding env noBinderInfo out_id rhs
 610
 611 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
 612 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 613                       occ_info out_id rhs
 614   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
 615   where
 616     new_out_id_env | okToInline form occ_info (couldBeSmallEnoughToInline guidance)
 617                    = out_id_env_with_unfolding
 618                    | otherwise
 619                    = out_id_env
 620         -- Don't bother to extend the OutIdEnv unless there is some possibility
 621         -- that the thing might be inlined.  We check this by calling okToInline suitably.
 622
 623     new_con_apps = _scc_ "eegnr.conapps"
 624                    extendConApps con_apps out_id rhs
 625
 626         -- Modify the occ info for rhs's interesting free variables.
 627     out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
 628                                 foldl modifyOccInfo env1 full_fv_occ_info
 629                 -- NB: full_fv_occ_info *combines* the occurrence of the current binder
 630                 -- with the occurrences of its RHS's free variables.  That's to take
 631                 -- account of:
 632                 --              let a = \x -> BIG in
 633                 --              let b = \f -> f a
 634                 --              in ...b...b...b...
 635                 -- Here "a" occurs exactly once. "b" simplifies to a small value.
 636                 -- So "b" will be inlined at each call site, and there's a good chance
 637                 -- that "a" will too.  So we'd better modify "a"s occurrence info to
 638                 -- record the fact that it can now occur many times by virtue that "b" can.
 639
 640     full_fv_occ_info          = _scc_ "eegnr.full_fv"
 641                                 [ (uniq, fv_occ `andBinderInfo` occ_info)
 642                                 | (uniq, fv_occ) <- ufmToList fv_occ_info
 643                                 ]
 644
 645         -- Add an unfolding and rhs_info for the new Id.
 646         -- If the out_id is already in the OutIdEnv (which can happen if
 647         -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
 648         -- then just replace the unfolding, leaving occurrence info alone.
 649     env1                      = _scc_ "eegnr.modify_out"
 650                                 addToUFM_C modifyOutEnvItem out_id_env out_id
 651                                            (out_id, occ_info, rhs_info)
 652
 653         -- Occurrence-analyse the RHS
 654         -- The "interesting" free variables we want occurrence info for are those
 655         -- in the OutIdEnv that have only a single occurrence right now.
 656     (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
 657                               occurAnalyseExpr is_interesting rhs
 658
 659     is_interesting v        = _scc_ "eegnr.mkidset"
 660                               case lookupIdEnv out_id_env v of
 661                                 Just (_, OneOcc _ _ _ _ _, _) -> True
 662                                 other                         -> False
 663
 664         -- Compute unfolding details
 665     rhs_info = OutUnfolding unf_cc (SimpleUnfolding form guidance template)
 666     form     = _scc_ "eegnr.form_sum"
 667                mkFormSummary rhs
 668     guidance = _scc_ "eegnr.guidance"
 669                mkSimplUnfoldingGuidance chkr out_id rhs
 670
 671         -- Compute cost centre for thing
 672     unf_cc  | noCostCentreAttached expr_cc = encl_cc
 673             | otherwise                    = expr_cc
 674             where
 675               expr_cc =  coreExprCc rhs
 676 \end{code}