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