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