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 IMPORT_DELOOPER(SmplLoop)               -- breaks the MagicUFs / SimplEnv loop
  50
  51 import BinderInfo       ( orBinderInfo, andBinderInfo, noBinderInfo,
  52                           BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
  53                         )
  54 import CmdLineOpts      ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
  55                           SimplifierSwitch(..), SwitchResult(..)
  56                         )
  57 import CoreSyn
  58 import CoreUnfold       ( mkFormSummary, exprSmallEnoughToDup,
  59                           Unfolding(..), UfExpr, RdrName,
  60                           SimpleUnfolding(..), FormSummary(..),
  61                           calcUnfoldingGuidance, UnfoldingGuidance(..)
  62                         )
  63 import CoreUtils        ( coreExprCc, unTagBinders )
  64 import CostCentre       ( CostCentre, noCostCentre, noCostCentreAttached )
  65 import FiniteMap        -- lots of things
  66 import Id               ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
  67                           applyTypeEnvToId, getInlinePragma,
  68                           nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
  69                           addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
  70                           SYN_IE(IdEnv), SYN_IE(IdSet), GenId, SYN_IE(Id) )
  71 import Literal          ( isNoRepLit, Literal{-instances-} )
  72 import Maybes           ( maybeToBool, expectJust )
  73 import Name             ( isLocallyDefined )
  74 import OccurAnal        ( occurAnalyseExpr )
  75 import Outputable       ( Outputable(..){-instances-} )
  76 import PprCore          -- various instances
  77 import PprStyle         ( PprStyle(..) )
  78 import PprType          ( GenType, GenTyVar )
  79 import Pretty
  80 import Type             ( eqTy, applyTypeEnvToTy, SYN_IE(Type) )
  81 import TyVar            ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
  82                           SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ,
  83                           SYN_IE(TyVar)
  84                         )
  85 import Unique           ( Unique{-instance Outputable-} )
  86 import UniqFM           ( addToUFM_C, ufmToList, Uniquable(..)
  87                         )
  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 noCostCentre 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 switchOffInlining :: SimplEnv -> SimplEnv
 188 switchOffInlining (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' EssentialUnfoldingsOnly = SwBool True
 192     chkr' other                   = chkr other
 193
 194 setCaseScrutinee :: SimplEnv -> SimplEnv
 195 setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 196   = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
 197   where
 198     chkr' SimplCaseScrutinee = SwBool True
 199     chkr' other              = chkr other
 200 \end{code}
 201
 202 %************************************************************************
 203 %*                                                                      *
 204 \subsubsection{The ``enclosing cost-centre''}
 205 %*                                                                      *
 206 %************************************************************************
 207
 208 \begin{code}
 209 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
 210
 211 setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
 212   = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
 213
 214 getEnclosingCC :: SimplEnv -> CostCentre
 215 getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
 216 \end{code}
 217
 218 %************************************************************************
 219 %*                                                                      *
 220 \subsubsection{The @TypeEnv@ part}
 221 %*                                                                      *
 222 %************************************************************************
 223
 224 \begin{code}
 225 type TypeEnv = TyVarEnv Type
 226 type InTypeEnv = TypeEnv        -- Maps InTyVars to OutTypes
 227
 228 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
 229 extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
 230   = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
 231   where
 232     new_ty_env = addOneToTyVarEnv ty_env tyvar ty
 233
 234 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
 235 extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
 236   = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
 237   where
 238     new_ty_env = growTyVarEnvList ty_env pairs
 239
 240 simplTy     (SimplEnv _ _ ty_env _ _ _) ty = returnEager (applyTypeEnvToTy ty_env ty)
 241 simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id)
 242 \end{code}
 243
 244 %************************************************************************
 245 %*                                                                      *
 246 \subsubsection{The ``Id env'' part}
 247 %*                                                                      *
 248 %************************************************************************
 249
 250 \begin{code}
 251 type InIdEnv = IdEnv OutArg     -- Maps InIds to their value
 252                                 -- Usually this is just the cloned Id, but if
 253                                 -- if the orig defn is a let-binding, and
 254                                 -- the RHS of the let simplifies to an atom,
 255                                 -- we just bind the variable to that atom, and
 256                                 -- elide the let.
 257 \end{code}
 258
 259 \begin{code}
 260 lookupId :: SimplEnv -> Id -> Eager ans OutArg
 261
 262 lookupId (SimplEnv _ _ _ in_id_env _ _) id
 263   = case (lookupIdEnv in_id_env id) of
 264       Just atom -> returnEager atom
 265       Nothing   -> returnEager (VarArg id)
 266 \end{code}
 267
 268 \begin{code}
 269 extendIdEnvWithAtom
 270         :: SimplEnv
 271         -> InBinder
 272         -> OutArg{-Val args only, please-}
 273         -> SimplEnv
 274
 275 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 276                     (in_id,occ_info) atom
 277   = case atom of
 278      LitArg _      -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 279      VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env
 280                                (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps
 281 --SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
 282   where
 283     new_in_id_env  = addOneToIdEnv in_id_env in_id atom
 284 {-
 285     new_out_id_env = case atom of
 286                         LitArg _      -> out_id_env
 287                         VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
 288 -}
 289
 290 extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
 291 extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 292
 293
 294 extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
 295
 296 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 297                      (in_id,_) out_id
 298   = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 299   where
 300     new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
 301
 302 extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
 303 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 304                       in_binders out_ids
 305   = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 306   where
 307     new_in_id_env = growIdEnvList in_id_env bindings
 308     bindings      = zipEqual "extendIdEnvWithClones"
 309                              [id | (id,_) <- in_binders]
 310                              (map VarArg out_ids)
 311 \end{code}
 312
 313 %************************************************************************
 314 %*                                                                      *
 315 \subsubsection{The @OutIdEnv@}
 316 %*                                                                      *
 317 %************************************************************************
 318
 319
 320 The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
 321 both locally-bound ones, and perhaps some imported ones too.
 322
 323 \begin{code}
 324 type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
 325
 326 \end{code}
 327
 328 The "Id" part is just so that we can recover the domain of the mapping, which
 329 IdEnvs don't allow directly.
 330
 331 The @BinderInfo@ tells about the occurrences of the @OutId@.
 332 Anything that isn't in here should be assumed to occur many times.
 333 We keep this info so we can modify it when something changes.
 334
 335 The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
 336
 337 \begin{code}
 338 data RhsInfo = NoRhsInfo
 339              | OtherLit [Literal]               -- It ain't one of these
 340              | OtherCon [Id]                    -- It ain't one of these
 341
 342              | InUnfolding SimplEnv             -- Un-simplified unfolding
 343                            SimpleUnfolding      -- (need to snag envts therefore)
 344
 345              | OutUnfolding CostCentre
 346                             SimpleUnfolding     -- Already-simplified unfolding
 347
 348 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
 349 lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
 350
 351 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
 352 lookupRhsInfo env id
 353   = case lookupOutIdEnv env id of
 354         Just (_,_,info) -> info
 355         Nothing         -> NoRhsInfo
 356
 357 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
 358                  -> (OutId, BinderInfo, RhsInfo)
 359                  -> (OutId, BinderInfo, RhsInfo)
 360 modifyOutEnvItem (id, occ, info1) (_, _, info2)
 361   = case (info1, info2) of
 362                 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
 363                 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
 364                 (_,            NoRhsInfo)    -> (id,occ, info1)
 365                 other                        -> (id,occ, info2)
 366 \end{code}
 367
 368
 369 \begin{code}
 370 isEvaluated :: RhsInfo -> Bool
 371 isEvaluated (OtherLit _) = True
 372 isEvaluated (OtherCon _) = True
 373 isEvaluated (InUnfolding _  (SimpleUnfolding ValueForm _ expr)) = True
 374 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
 375 isEvaluated other = False
 376 \end{code}
 377
 378
 379
 380 \begin{code}
 381 mkSimplUnfoldingGuidance chkr out_id rhs
 382   = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
 383
 384 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
 385 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 386                       out_id occ_info rhs_info
 387   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 388   where
 389     new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
 390                                 (out_id, occ_info, rhs_info)
 391 \end{code}
 392
 393
 394 \begin{code}
 395 modifyOccInfo out_id_env (uniq, new_occ)
 396   = modifyIdEnv_Directly modify_fn out_id_env uniq
 397   where
 398     modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
 399
 400 markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
 401   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 402   where
 403     new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
 404     modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
 405 \end{code}
 406
 407
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 \subsubsection{The @ConAppMap@ type}
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 The @ConAppMap@ maps applications of constructors (to value atoms)
 416 back to an association list that says "if the constructor was applied
 417 to one of these lists-of-Types, then this OutId is your man (in a
 418 non-gender-specific sense)".  I.e., this is a reversed mapping for
 419 (part of) the main OutIdEnv
 420
 421 \begin{code}
 422 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
 423
 424 data UnfoldConApp
 425   = UCA         OutId                   -- data constructor
 426                 [OutArg]                -- *value* arguments; see use below
 427 \end{code}
 428
 429 \begin{code}
 430 nullConApps = emptyFM
 431
 432 extendConApps con_apps id (Con con args)
 433   = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
 434   where
 435     val_args = filter isValArg args             -- Literals and Ids
 436     ty_args  = [ty | TyArg ty <- args]          -- Just types
 437
 438 extendConApps con_apps id other_rhs = con_apps
 439 \end{code}
 440
 441 \begin{code}
 442 lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
 443   = case lookupFM con_apps (UCA con val_args) of
 444         Nothing     -> Nothing
 445
 446         Just assocs -> case [id | (tys, id) <- assocs,
 447                                   and (zipWith eqTy tys ty_args)]
 448                        of
 449                           []     -> Nothing
 450                           (id:_) -> Just id
 451   where
 452     val_args = filter isValArg args             -- Literals and Ids
 453     ty_args  = [ty | TyArg ty <- args]          -- Just types
 454
 455 \end{code}
 456
 457 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
 458 for nullary constructors, but now we only do constructor re-use in
 459 let-bindings the special case isn't necessary any more.
 460
 461 \begin{verbatim}
 462   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 463         -- let
 464         --        a = leInt#! p q
 465         -- in
 466         -- case a of
 467         --    True  -> ...
 468         --    False -> False
 469         --
 470         -- Here the False in the second case will get replace by "a", hardly
 471         -- a good idea
 472     Nothing
 473 \end{verbatim}
 474
 475
 476 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 477 it, so we can use it for a @FiniteMap@ key.
 478
 479 \begin{code}
 480 instance Eq  UnfoldConApp where
 481     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
 482     a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
 483
 484 instance Ord UnfoldConApp where
 485     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 486     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 487     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 488     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 489     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 490
 491 instance Ord3 UnfoldConApp where
 492     cmp = cmp_app
 493
 494 cmp_app (UCA c1 as1) (UCA c2 as2)
 495   = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
 496   where
 497     -- ToDo: make an "instance Ord3 CoreArg"???
 498
 499     cmp_arg (VarArg   x) (VarArg   y) = x `cmp` y
 500     cmp_arg (LitArg   x) (LitArg   y) = x `cmp` y
 501     cmp_arg (TyArg    x) (TyArg    y) = panic# "SimplEnv.cmp_app:TyArgs"
 502     cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
 503     cmp_arg x y
 504       | tag x _LT_ tag y = LT_
 505       | otherwise        = GT_
 506       where
 507         tag (VarArg   _) = ILIT(1)
 508         tag (LitArg   _) = ILIT(2)
 509         tag (TyArg    _) = panic# "SimplEnv.cmp_app:TyArg"
 510         tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
 511 \end{code}
 512
 513
 514
 515
 516
 517 ============================  OLD ================================
 518         This version was used when we use the *simplified* RHS of a
 519         let as the thing's unfolding.  The has the nasty property described
 520         in the following comments.  Much worse, it can fail to terminate
 521         on recursive things.  Consider
 522
 523                 letrec f = \x -> let z = f x' in ...
 524
 525                 in
 526                 let n = f y
 527                 in
 528                 case n of { ... }
 529
 530         If we bind n to its *simplified* RHS, we then *re-simplify* it when
 531         we inline n.  Then we may well inline f; and then the same thing
 532         happens with z!
 533
 534
 535 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 536 of a new binding.  There is a horrid case we have to take care about,
 537 due to Andr\'e Santos:
 538 @
 539     type Array_type b   = Array Int b;
 540     type Descr_type     = (Int,Int);
 541
 542     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 543     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 544
 545     f_iaamain a_xs=
 546         let {
 547             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 548             f_aareorder a_index a_ar=
 549                 let {
 550                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 551                  } in  tabulate f_aareorder' (bounds a_ar);
 552             r_index=tabulate ((+) 1) (1,1);
 553             arr    = listArray (1,1) a_xs;
 554             arg    = f_aareorder r_index arr
 555          } in  elems arg
 556 @
 557 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 558 @
 559         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 560                in tabulate f_aareorder' (bounds arr)
 561 @
 562 Note that r_index is not inlined, because it was bound to a_index which
 563 occurs inside a lambda.
 564
 565 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 566 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 567 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 568 will get inlined inside the lambda.  AARGH.
 569
 570 Solution: when we occurrence-analyse the new RHS we have to go back
 571 and modify the info recorded in the UnfoldEnv for the free vars
 572 of the RHS.  In the example we'd go back and record that r_index is now used
 573 inside a lambda.
 574
 575 \begin{code}
 576 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 577 extendEnvGivenNewRhs env out_id rhs
 578   = extendEnvGivenBinding env noBinderInfo out_id rhs
 579
 580 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
 581 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 582                       occ_info out_id rhs
 583   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
 584   where
 585     new_out_id_env = case guidance of
 586                         UnfoldNever -> out_id_env               -- No new stuff to put in
 587                         other       -> out_id_env_with_unfolding
 588
 589     new_con_apps = _scc_ "eegnr.conapps"
 590                    extendConApps con_apps out_id rhs
 591
 592         -- Modify the occ info for rhs's interesting free variables.
 593     out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
 594                                 foldl modifyOccInfo env1 full_fv_occ_info
 595                 -- NB: full_fv_occ_info *combines* the occurrence of the current binder
 596                 -- with the occurrences of its RHS's free variables.  That's to take
 597                 -- account of:
 598                 --              let a = \x -> BIG in
 599                 --              let b = \f -> f a
 600                 --              in ...b...b...b...
 601                 -- Here "a" occurs exactly once. "b" simplifies to a small value.
 602                 -- So "b" will be inlined at each call site, and there's a good chance
 603                 -- that "a" will too.  So we'd better modify "a"s occurrence info to
 604                 -- record the fact that it can now occur many times by virtue that "b" can.
 605
 606     full_fv_occ_info          = _scc_ "eegnr.full_fv"
 607                                 [ (uniq, fv_occ `andBinderInfo` occ_info)
 608                                 | (uniq, fv_occ) <- ufmToList fv_occ_info
 609                                 ]
 610
 611         -- Add an unfolding and rhs_info for the new Id.
 612         -- If the out_id is already in the OutIdEnv (which can happen if
 613         -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
 614         -- then just replace the unfolding, leaving occurrence info alone.
 615     env1                      = _scc_ "eegnr.modify_out"
 616                                 addToUFM_C modifyOutEnvItem out_id_env out_id
 617                                            (out_id, occ_info, rhs_info)
 618
 619         -- Occurrence-analyse the RHS
 620         -- The "interesting" free variables we want occurrence info for are those
 621         -- in the OutIdEnv that have only a single occurrence right now.
 622     (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
 623                               occurAnalyseExpr is_interesting rhs
 624
 625     is_interesting v        = _scc_ "eegnr.mkidset"
 626                               case lookupIdEnv out_id_env v of
 627                                 Just (_, OneOcc _ _ _ _ _, _) -> True
 628                                 other                         -> False
 629
 630         -- Compute unfolding details
 631     rhs_info     = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template)
 632     form_summary = _scc_ "eegnr.form_sum"
 633                    mkFormSummary rhs
 634     guidance     = _scc_ "eegnr.guidance"
 635                    mkSimplUnfoldingGuidance chkr out_id rhs
 636
 637         -- Compute cost centre for thing
 638     unf_cc  | noCostCentreAttached expr_cc = encl_cc
 639             | otherwise                    = expr_cc
 640             where
 641               expr_cc =  coreExprCc rhs
 642 \end{code}
 643
 644
 645
 646
 647 ========================== OLD [removed SLPJ March 97] ====================
 648
 649 I removed the attempt to inline recursive bindings when I discovered
 650 a program that made the simplifier loop  (nofib/spectral/hartel/typecheck/Main.hs)
 651
 652 The nasty case is this:
 653
 654                 letrec f = \x -> let z = f x' in ...
 655
 656                 in
 657                 let n = f y
 658                 in
 659                 case n of { ... }
 660
 661 If we bind n to its *simplified* RHS, we then *re-simplify* it when we
 662 inline n.  Then we may well inline f; and then the same thing happens
 663 with z!
 664
 665 Recursive bindings
 666 ~~~~~~~~~~~~~~~~~~
 667 We need to be pretty careful when extending
 668 the environment with RHS info in recursive groups.
 669
 670 Here's a nasty example:
 671
 672         letrec  r = f x
 673                 t = r
 674                 x = ...t...
 675         in
 676         ...t...
 677
 678 Here, r occurs exactly once, so we may reasonably inline r in t's RHS.
 679 But the pre-simplified t's rhs is an atom, r, so we may also decide to
 680 inline t everywhere.  But if we do *both* these reasonable things we get
 681
 682         letrec  r = f x
 683                 t = f x
 684                 x = ...r...
 685         in
 686         ...t...
 687
 688 Bad news!  (f x) is duplicated!  (The t in the body doesn't get
 689 inlined because by the time the recursive group is done we see that
 690 t's RHS isn't an atom.)
 691
 692 Our solution is this:
 693         (a) we inline un-simplified RHSs, and then simplify
 694             them in a clone-only environment.
 695         (b) we inline only variables and values
 696 This means that
 697
 698
 699         r = f x         ==>  r = f x
 700         t = r           ==>  t = r
 701         x = ...t...     ==>  x = ...r...
 702      in                    in
 703         t                    r
 704
 705 Now t is dead, and we're home.
 706
 707 Most silly x=y  bindings in recursive group will go away.  But not all:
 708
 709         let y = 1:x
 710             x = y
 711
 712 Here, we can't inline x because it's in an argument position. so we'll just replace
 713 with a clone of y.  Instead we'll probably inline y (a small value) to give
 714
 715         let y = 1:x
 716             x = 1:y
 717
 718 which is OK if not clever.
 719
 720
 721
 722 \begin{code}
 723 {-
 724 extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 725                        (out_id, ((_,occ_info), old_rhs))
 726   = case (form_summary, guidance) of
 727      (_, UnfoldNever)   -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in
 728      (ValueForm, _)     -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
 729      (VarForm, _)       -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
 730      other              -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps   -- Not a value or variable
 731
 732 -- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 733   where
 734 {-
 735     new_out_id_env = case (form_summary, guidance) of
 736                         (_, UnfoldNever)        -> out_id_env           -- No new stuff to put in
 737                         (ValueForm, _)          -> out_id_env_with_unfolding
 738                         (VarForm, _)            -> out_id_env_with_unfolding
 739                         other                   -> out_id_env           -- Not a value or variable
 740 -}
 741         -- If there is an unfolding, we add rhs-info for out_id,
 742         -- No need to modify occ info because RHS is pre-simplification
 743     out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id
 744                                 (out_id, occ_info, rhs_info)
 745
 746         -- Compute unfolding details
 747         -- Note that we use the "old" environment, that just has clones of the rec-bound vars,
 748         -- in the InUnfolding.  So if we ever use the InUnfolding we'll just inline once.
 749         -- Only if the thing is still small enough next time round will we inline again.
 750     rhs_info     = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
 751     form_summary = mkFormSummary old_rhs
 752     guidance     = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)
 753 -}
 754 \end{code}