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,
  11         pprSimplEnv, -- debugging only
  12
  13         replaceInEnvs, nullInEnvs,
  14
  15         extendTyEnv, extendTyEnvList,
  16         simplTy, simplTyInId,
  17
  18         extendIdEnvWithAtom, extendIdEnvWithAtomList,
  19         extendIdEnvWithInlining,
  20         extendIdEnvWithClone, extendIdEnvWithClones,
  21         lookupId,
  22
  23         extendUnfoldEnvGivenRhs,
  24         extendUnfoldEnvGivenFormDetails,
  25         extendUnfoldEnvGivenConstructor,
  26         lookForConstructor,
  27         lookupUnfolding, filterUnfoldEnvForInlines,
  28
  29         getSwitchChecker, switchIsSet,
  30
  31         setEnclosingCC,
  32
  33         -- Types
  34         SwitchChecker(..),
  35         SimplEnv, EnclosingCcDetails(..),
  36         InIdEnv(..), IdVal(..), InTypeEnv(..),
  37         UnfoldEnv, UnfoldItem, UnfoldConApp,
  38
  39         InId(..),  InBinder(..),  InBinding(..),  InType(..),
  40         OutId(..), OutBinder(..), OutBinding(..), OutType(..),
  41
  42         InExpr(..),  InAlts(..),  InDefault(..),  InArg(..),
  43         OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..)
  44     ) where
  45
  46 import Ubiq{-uitous-}
  47
  48 import SmplLoop         -- breaks the MagicUFs / SimplEnv loop
  49
  50 import BinderInfo       ( BinderInfo{-instances-} )
  51 import CgCompInfo       ( uNFOLDING_CREATION_THRESHOLD )
  52 import CmdLineOpts      ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
  53 import CoreSyn
  54 import CoreUnfold       ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
  55                           calcUnfoldingGuidance, UnfoldingGuidance(..),
  56                           mkFormSummary, FormSummary
  57                         )
  58 import CoreUtils        ( manifestlyWHNF, exprSmallEnoughToDup )
  59 import FiniteMap        -- lots of things
  60 import Id               ( idType, getIdUnfolding, getIdStrictness,
  61                           applyTypeEnvToId,
  62                           nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
  63                           addOneToIdEnv, modifyIdEnv,
  64                           IdEnv(..), IdSet(..), GenId )
  65 import IdInfo           ( bottomIsGuaranteed, StrictnessInfo )
  66 import Literal          ( isNoRepLit, Literal{-instances-} )
  67 import Name             ( isLocallyDefined )
  68 import OccurAnal        ( occurAnalyseExpr )
  69 import Outputable       ( Outputable(..){-instances-} )
  70 import PprCore          -- various instances
  71 import PprStyle         ( PprStyle(..) )
  72 import PprType          ( GenType, GenTyVar )
  73 import Pretty
  74 import Type             ( eqTy, getAppDataTyCon, applyTypeEnvToTy )
  75 import TyVar            ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
  76                           growTyVarEnvList,
  77                           TyVarEnv(..), GenTyVar{-instance Eq-}
  78                         )
  79 import Unique           ( Unique{-instance Outputable-} )
  80 import UniqFM           ( addToUFM_Directly, lookupUFM_Directly, ufmToList )
  81 import UniqSet          -- lots of things
  82 import Usage            ( UVar(..), GenUsage{-instances-} )
  83 import Util             ( zipEqual, panic, panic#, assertPanic )
  84
  85 type TypeEnv = TyVarEnv Type
  86 cmpType = panic "cmpType (SimplEnv)"
  87 oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
  88 oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
  89 simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
  90 \end{code}
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection[Simplify-types]{Type declarations}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 \subsubsection{The @SimplEnv@ type}
 102 %*                                                                      *
 103 %************************************************************************
 104
 105
 106 INVARIANT: we assume {\em no shadowing}.  (ToDo: How can we ASSERT
 107 this? WDP 94/06) This allows us to neglect keeping everything paired
 108 with its static environment.
 109
 110 The environment contains bindings for all
 111         {\em in-scope,}
 112         {\em locally-defined}
 113 things.
 114
 115 For such things, any unfolding is found in the environment, not in the
 116 Id.  Unfoldings in the Id itself are used only for imported things
 117 (otherwise we get trouble because we have to simplify the unfoldings
 118 inside the Ids, etc.).
 119
 120 \begin{code}
 121 data SimplEnv
 122   = SimplEnv
 123         SwitchChecker
 124
 125         EnclosingCcDetails -- the enclosing cost-centre (when profiling)
 126
 127         InTypeEnv       -- For cloning types
 128                         -- Domain is all in-scope type variables
 129
 130         InIdEnv         -- IdEnv
 131                         -- Domain is
 132                         --      *all*
 133                         --      *in-scope*,
 134                         --      *locally-defined*
 135                         --      *InIds*
 136                         -- (Could omit the exported top-level guys,
 137                         -- since their names mustn't change; and ditto
 138                         -- the non-exported top-level guys which you
 139                         -- don't want to macro-expand, since their
 140                         -- names need not change.)
 141                         --
 142                         -- Starts off empty
 143
 144         UnfoldEnv       -- Domain is any *OutIds*, including imports
 145                         -- where we know something more than the
 146                         -- interface file tells about their value (see
 147                         -- below)
 148
 149 nullSimplEnv :: SwitchChecker -> SimplEnv
 150
 151 nullSimplEnv sw_chkr
 152   = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
 153
 154 pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
 155   = ppAboves [
 156         ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env,
 157         ppSP, ppStr "** Id Env ** ?????????",
 158 --      ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ],
 159         ppSP, ppStr "** Unfold Env **",
 160         ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ]
 161     ]
 162   where
 163     pp_id_entry (v, idval)
 164       = ppCat [ppr PprDebug v, ppStr "=>",
 165                case idval of
 166                  InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
 167                  ItsAnAtom a    -> ppCat [ppStr "Atom:", ppr PprDebug a]
 168               ]
 169
 170     pp_uf_entry (UnfoldItem v form encl_cc)
 171       = ppCat [ppr PprDebug v, ppStr "=>",
 172                case form of
 173                  NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
 174                  LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
 175                  OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
 176                                                                [ppr PprDebug l | l <- ls]]
 177                  ConForm c a     -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
 178                  OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
 179                                                               [ppr PprDebug c | c <- cs]]
 180                  GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w,
 181                                                         ppr PprDebug g, ppr PprDebug e]
 182                  MagicForm s _   -> ppCat [ppStr "Magic:", ppr PprDebug s]
 183               ]
 184 \end{code}
 185
 186 %************************************************************************
 187 %*                                                                      *
 188 \subsubsection{The @IdVal@ type (for the ``IdEnv'')}
 189 %*                                                                      *
 190 %************************************************************************
 191
 192 The unfoldings for imported things are mostly kept within the Id
 193 itself; nevertheless, they {\em can} get into the @UnfoldEnv@.  For
 194 example, suppose \tr{x} is imported, and we have
 195 \begin{verbatim}
 196         case x of
 197           (p,q) -> <body>
 198 \end{verbatim}
 199 Then within \tr{<body>}, we know that \tr{x} is a pair with components
 200 \tr{p} and \tr{q}.
 201
 202 \begin{code}
 203 type InIdEnv = IdEnv IdVal      -- Maps InIds to their value
 204
 205 data IdVal
 206   = InlineIt InIdEnv InTypeEnv InExpr
 207                 -- No binding of the Id is left;
 208                 -- You *have* to replace any occurences
 209                 -- of the id with this expression.
 210                 -- Rather like a macro, really
 211                 -- NB: the InIdEnv/InTypeEnv is necessary to prevent
 212                 -- name caputure. Consider:
 213                 --      let y = ...
 214                 --          x = ...y...
 215                 --          y = ...
 216                 --      in ...x...
 217                 -- If x gets an InlineIt, we must remember
 218                 -- the correct binding for y.
 219
 220   | ItsAnAtom OutArg    -- Used either (a) to record the cloned Id
 221                         -- or (b) if the orig defn is a let-binding, and
 222                         -- the RHS of the let simplifies to an atom,
 223                         -- we just bind the variable to that atom, and
 224                         -- elide the let.
 225 \end{code}
 226
 227 %************************************************************************
 228 %*                                                                      *
 229 \subsubsection{The @UnfoldEnv@ type}
 230 %*                                                                      *
 231 %************************************************************************
 232
 233 The @UnfoldEnv@ contains information about the value of some of the
 234 in-scope identifiers.  It obeys the following invariant:
 235
 236         If the @UnfoldEnv@ contains information, it is safe to use it!
 237
 238 In particular, if the @UnfoldEnv@ contains details of an unfolding of
 239 an Id, then it's safe to use the unfolding.  If, for example, the Id
 240 is used many times, then its unfolding won't be put in the UnfoldEnv
 241 at all.
 242
 243 The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
 244 because (a)~it's small, and (b)~we need to search its {\em range} as
 245 well as its domain.
 246
 247 \begin{code}
 248 data UnfoldItem -- a glorified triple...
 249   = UnfoldItem  OutId                   -- key: used in lookForConstructor
 250                 UnfoldingDetails        -- for that Id
 251                 EnclosingCcDetails      -- so that if we do an unfolding,
 252                                         -- we can "wrap" it in the CC
 253                                         -- that was in force.
 254
 255 data UnfoldConApp -- yet another glorified pair
 256   = UCA         OutId                   -- same fields as ConForm
 257                 [OutArg]
 258
 259 data UnfoldEnv  -- yup, a glorified triple...
 260   = UFE         (IdEnv UnfoldItem)      -- Maps an OutId => its UnfoldItem
 261                 IdSet                   -- The Ids in the domain of the env
 262                                         -- which have details (GenForm True ...)
 263                                         -- i.e., they claim they are duplicatable.
 264                                         -- These are the ones we have to worry
 265                                         -- about when adding new items to the
 266                                         -- unfold env.
 267                 (FiniteMap UnfoldConApp OutId)
 268                                         -- Maps applications of constructors (to
 269                                         -- types & atoms) back to OutIds that are
 270                                         -- bound to them; i.e., this is a reversed
 271                                         -- mapping for (part of) the main IdEnv
 272                                         -- (1st part of UFE)
 273
 274 null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
 275 \end{code}
 276
 277 The @UnfoldEnv@ type.  We expect on the whole that an @UnfoldEnv@ will
 278 be small, because it contains bindings only for those things whose
 279 form or unfolding is known.  Basically it maps @Id@ to their
 280 @UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
 281 need to search it associatively, to look for @Id@s which have a given
 282 constructor form.
 283
 284 We implement it with @IdEnvs@, possibly overkill, but sometimes these
 285 things silently grow quite big....  Here are some local functions used
 286 elsewhere in the module:
 287
 288 \begin{code}
 289 grow_unfold_env   :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
 290 lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
 291 lookup_unfold_env_encl_cc
 292                   :: UnfoldEnv -> OutId -> EnclosingCcDetails
 293
 294 grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
 295
 296 grow_unfold_env (UFE u_env interesting_ids con_apps) id
 297                 uf_details@(GenForm True _ _ _) encl_cc
 298     -- Only interested in Ids which have a "dangerous" unfolding; that is
 299     -- one that claims to have a single occurrence.
 300   = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
 301         (addOneToUniqSet interesting_ids id)
 302         con_apps
 303
 304 grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
 305   = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
 306         interesting_ids
 307         new_con_apps
 308   where
 309     new_con_apps
 310       = case uf_details of
 311           ConForm con args
 312             -> case (lookupFM con_apps entry) of
 313                  Just _  -> con_apps -- unchanged; we hang onto what we have
 314                  Nothing -> addToFM con_apps entry id
 315             where
 316               entry = UCA con args
 317
 318           not_a_constructor -> con_apps -- unchanged
 319
 320 addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
 321   = ASSERT(not (any constructor_form_in_those extra_items))
 322     -- otherwise, we'd need to change con_apps
 323     UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
 324   where
 325     constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
 326     constructor_form_in_those _ = False
 327
 328 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
 329
 330 get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
 331
 332 foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
 333   = UFE (foldr fun u_env stuff) interesting_ids con_apps
 334
 335 lookup_unfold_env (UFE u_env _ _) id
 336   = case (lookupIdEnv u_env id) of
 337       Nothing                  -> NoUnfoldingDetails
 338       Just (UnfoldItem _ uf _) -> uf
 339
 340 lookup_unfold_env_encl_cc (UFE u_env _ _) id
 341   = case (lookupIdEnv u_env id) of
 342       Nothing                       -> NoEnclosingCcDetails
 343       Just (UnfoldItem _ _ encl_cc) -> encl_cc
 344
 345 lookup_conapp (UFE _ _ con_apps) con args
 346   = lookupFM con_apps (UCA con args)
 347
 348 modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
 349   = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
 350
 351 -- If the current binding claims to be a "unique" one, then
 352 -- we modify it.
 353 modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
 354
 355 modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
 356   = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
 357 \end{code}
 358
 359 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 360 it, so we can use it for a @FiniteMap@ key.
 361 \begin{code}
 362 instance Eq  UnfoldConApp where
 363     a == b = case cmp_app a b of { EQ_ -> True;   _ -> False }
 364     a /= b = case cmp_app a b of { EQ_ -> False;  _ -> True  }
 365
 366 instance Ord UnfoldConApp where
 367     a <= b = case cmp_app a b of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 368     a <  b = case cmp_app a b of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 369     a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 370     a >  b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 371     _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 372
 373 instance Ord3 UnfoldConApp where
 374     cmp = cmp_app
 375
 376 cmp_app (UCA c1 as1) (UCA c2 as2)
 377   = case (c1 `cmp` c2) of
 378       LT_ -> LT_
 379       GT_ -> GT_
 380       _   -> cmp_lists cmp_arg as1 as2
 381   where
 382     cmp_lists cmp_item []     []     = EQ_
 383     cmp_lists cmp_item (x:xs) []     = GT_
 384     cmp_lists cmp_item []     (y:ys) = LT_
 385     cmp_lists cmp_item (x:xs) (y:ys)
 386       = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
 387
 388     -- ToDo: make an "instance Ord3 CoreArg"???
 389
 390     cmp_arg (VarArg   x) (VarArg   y) = x `cmp` y
 391     cmp_arg (LitArg   x) (LitArg   y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
 392     cmp_arg (TyArg    x) (TyArg    y) = if x `eqTy` y then EQ_ else panic# "SimplEnv.cmp_app:TyArgs"
 393     cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
 394     cmp_arg x y
 395       | tag x _LT_ tag y = LT_
 396       | otherwise        = GT_
 397       where
 398         tag (VarArg   _) = ILIT(1)
 399         tag (LitArg   _) = ILIT(2)
 400         tag (TyArg    _) = ILIT(3)
 401         tag (UsageArg _) = ILIT(4)
 402 \end{code}
 403
 404 %************************************************************************
 405 %*                                                                      *
 406 \subsubsection{The @EnclosingCcDetails@ type}
 407 %*                                                                      *
 408 %************************************************************************
 409
 410 \begin{code}
 411 data EnclosingCcDetails
 412   = NoEnclosingCcDetails
 413   | EnclosingCC     CostCentre
 414 \end{code}
 415
 416 %************************************************************************
 417 %*                                                                      *
 418 \subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
 419 %*                                                                      *
 420 %************************************************************************
 421
 422 \begin{code}
 423 type InId      = Id                     -- Not yet cloned
 424 type InBinder  = (InId, BinderInfo)
 425 type InType    = Type                   -- Ditto
 426 type InBinding = SimplifiableCoreBinding
 427 type InExpr    = SimplifiableCoreExpr
 428 type InAlts    = SimplifiableCoreCaseAlts
 429 type InDefault = SimplifiableCoreCaseDefault
 430 type InArg     = SimplifiableCoreArg
 431
 432 type OutId      = Id                    -- Cloned
 433 type OutBinder  = Id
 434 type OutType    = Type                  -- Cloned
 435 type OutBinding = CoreBinding
 436 type OutExpr    = CoreExpr
 437 type OutAlts    = CoreCaseAlts
 438 type OutDefault = CoreCaseDefault
 439 type OutArg     = CoreArg
 440
 441 \end{code}
 442
 443 \begin{code}
 444 type SwitchChecker = SimplifierSwitch -> SwitchResult
 445 \end{code}
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection{@SimplEnv@ handling}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 \subsubsection{Command-line switches}
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 \begin{code}
 460 getSwitchChecker :: SimplEnv -> SwitchChecker
 461 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
 462
 463 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
 464 switchIsSet (SimplEnv chkr _ _ _ _) switch
 465   = switchIsOn chkr switch
 466 \end{code}
 467
 468 %************************************************************************
 469 %*                                                                      *
 470 \subsubsection{The ``enclosing cost-centre''}
 471 %*                                                                      *
 472 %************************************************************************
 473
 474 \begin{code}
 475 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
 476
 477 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
 478   = SimplEnv chkr encl_cc ty_env id_env unfold_env
 479 \end{code}
 480
 481 %************************************************************************
 482 %*                                                                      *
 483 \subsubsection{The @TypeEnv@ part}
 484 %*                                                                      *
 485 %************************************************************************
 486
 487 \begin{code}
 488 type InTypeEnv = TypeEnv        -- Maps InTyVars to OutTypes
 489
 490 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
 491 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
 492   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 493   where
 494     new_ty_env = addOneToTyVarEnv ty_env tyvar ty
 495
 496 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
 497 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
 498   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 499   where
 500     new_ty_env = growTyVarEnvList ty_env pairs
 501
 502 simplTy     (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
 503 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
 504 \end{code}
 505
 506 @replaceInEnvs@ is used to install saved type and id envs
 507 when pulling an un-simplified expression out of the environment, which
 508 was saved with its environments.
 509
 510 \begin{code}
 511 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
 512
 513 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
 514
 515 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 516               (new_ty_env, new_id_env)
 517   = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
 518 \end{code}
 519
 520 %************************************************************************
 521 %*                                                                      *
 522 \subsubsection{The ``Id env'' part}
 523 %*                                                                      *
 524 %************************************************************************
 525
 526 \begin{code}
 527 extendIdEnvWithAtom
 528         :: SimplEnv
 529         -> InBinder -> OutArg{-Val args only, please-}
 530         -> SimplEnv
 531
 532 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
 533   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 534   where
 535     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 536
 537 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 538             (in_id, occ_info) atom@(VarArg out_id)
 539   = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
 540   where
 541     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 542
 543     new_unfold_env = modify_unfold_env
 544                         unfold_env
 545                         (modifyItem ok_to_dup occ_info)
 546                         out_id
 547                 -- Modify binding for in_id
 548                 -- NO! modify out_id, because its the info on the
 549                 -- atom that interest's us.
 550
 551     ok_to_dup    = switchIsOn chkr SimplOkToDupCode
 552
 553 #ifdef DEBUG
 554 extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
 555 #endif
 556
 557 extendIdEnvWithAtomList
 558         :: SimplEnv
 559         -> [(InBinder, OutArg)]
 560         -> SimplEnv
 561 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 562
 563 extendIdEnvWithInlining
 564         :: SimplEnv             -- The Env to modify
 565         -> SimplEnv             -- The Env to record in the inlining.  Usually the
 566                                 -- same as the previous one, except in the recursive case
 567         -> InBinder -> InExpr
 568         -> SimplEnv
 569
 570 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env        id_env        unfold_env)
 571                         ~(SimplEnv _   _       inline_ty_env inline_id_env _         )
 572                         (in_id,occ_info)
 573                         expr
 574   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 575   where
 576     new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
 577
 578 extendIdEnvWithClone
 579         :: SimplEnv
 580         -> InBinder     -- Old binder; binderinfo ignored
 581         -> OutId        -- Its new clone, as an Id
 582         -> SimplEnv
 583
 584 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 585         (in_id,_) out_id
 586   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 587   where
 588     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
 589
 590 extendIdEnvWithClones   -- Like extendIdEnvWithClone
 591         :: SimplEnv
 592         -> [InBinder]
 593         -> [OutId]
 594         -> SimplEnv
 595
 596 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 597         in_binders out_ids
 598   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 599   where
 600     new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
 601     in_ids     = [id | (id,_) <- in_binders]
 602     out_vals   = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
 603
 604 lookupId :: SimplEnv -> Id -> Maybe IdVal
 605
 606 lookupId (SimplEnv _ _ _ id_env _) id
 607 #ifndef DEBUG
 608   = lookupIdEnv id_env id
 609 #else
 610   = case (lookupIdEnv id_env id) of
 611       xxx@(Just _) -> xxx
 612       xxx          -> --false!: ASSERT(not (isLocallyDefined id))
 613                       xxx
 614 #endif
 615 \end{code}
 616
 617 %************************************************************************
 618 %*                                                                      *
 619 \subsubsection{The @UnfoldEnv@}
 620 %*                                                                      *
 621 %************************************************************************
 622
 623 \begin{code}
 624 extendUnfoldEnvGivenFormDetails
 625         :: SimplEnv
 626         -> OutId
 627         -> UnfoldingDetails
 628         -> SimplEnv
 629
 630 extendUnfoldEnvGivenFormDetails
 631         env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 632         id details
 633   = case details of
 634       NoUnfoldingDetails -> env
 635       good_details       -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 636         where
 637           new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
 638
 639 extendUnfoldEnvGivenConstructor -- specialised variant
 640         :: SimplEnv
 641         -> OutId                -- bind this to...
 642         -> Id -> [OutId]        -- "con <tys-to-be-invented> args"
 643         -> SimplEnv
 644
 645 extendUnfoldEnvGivenConstructor env var con args
 646   = let
 647         -- conjure up the types to which the con should be applied
 648         scrut_ty        = idType var
 649         (_, ty_args, _) = getAppDataTyCon scrut_ty
 650     in
 651     extendUnfoldEnvGivenFormDetails
 652       env var (ConForm con (map VarArg args))
 653 \end{code}
 654
 655
 656 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 657 of a new binding.  There is a horrid case we have to take care about,
 658 due to Andr\'e Santos:
 659 @
 660     type Array_type b   = Array Int b;
 661     type Descr_type     = (Int,Int);
 662
 663     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 664     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 665
 666     f_iaamain a_xs=
 667         let {
 668             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 669             f_aareorder a_index a_ar=
 670                 let {
 671                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 672                  } in  tabulate f_aareorder' (bounds a_ar);
 673             r_index=tabulate ((+) 1) (1,1);
 674             arr    = listArray (1,1) a_xs;
 675             arg    = f_aareorder r_index arr
 676          } in  elems arg
 677 @
 678 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 679 @
 680         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 681                in tabulate f_aareorder' (bounds arr)
 682 @
 683 Note that r_index is not inlined, because it was bound to a_index which
 684 occurs inside a lambda.
 685
 686 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 687 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 688 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 689 will get inlined inside the lambda.  AARGH.
 690
 691 Solution: when we occurrence-analyse the new RHS we have to go back
 692 and modify the info recorded in the UnfoldEnv for the free vars
 693 of the RHS.  In the example we'd go back and record that r_index is now used
 694 inside a lambda.
 695
 696 \begin{code}
 697 extendUnfoldEnvGivenRhs
 698         :: SimplEnv
 699         -> InBinder
 700         -> OutId        -- Note: *must* be an "out" Id (post-cloning)
 701         -> OutExpr      -- Its rhs (*simplified*)
 702         -> SimplEnv
 703
 704 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 705                         binder@(_,occ_info) out_id rhs
 706   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 707   where
 708         -- Occurrence-analyse the RHS
 709     (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
 710
 711     interesting_fvs = get_interesting_ids unfold_env
 712
 713         -- Compute unfolding details
 714     details = case rhs of
 715                 Var v                      -> panic "Vars already dealt with"
 716                 Lit lit | isNoRepLit lit -> LitForm lit
 717                           | otherwise      -> panic "non-noRep Lits already dealt with"
 718
 719                 Con con args               -> ConForm con args
 720
 721                 other -> mkGenForm ok_to_dup occ_info
 722                                    (mkFormSummary (getIdStrictness out_id) rhs)
 723                                    template guidance
 724
 725         -- Compute resulting unfold env
 726     new_unfold_env = case details of
 727                         NoUnfoldingDetails      -> unfold_env
 728                         GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
 729                         other                   -> unfold_env1
 730
 731         -- Add unfolding to unfold env
 732     unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
 733
 734         -- Modify unfoldings of free vars of rhs, based on their
 735         -- occurrence info in the rhs [see notes above]
 736     unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
 737
 738     modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
 739     modify (u, occ_info) env
 740       = case (lookupUFM_Directly env u) of
 741           Nothing -> env -- ToDo: can this happen?
 742           Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
 743
 744         -- Compute unfolding guidance
 745     guidance = if simplIdWantsToBeINLINEd out_id env
 746                then UnfoldAlways
 747                else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
 748
 749     bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
 750                       Nothing -> uNFOLDING_CREATION_THRESHOLD
 751                       Just xx -> xx
 752
 753     ok_to_dup     = switchIsOn chkr SimplOkToDupCode
 754                         || exprSmallEnoughToDup rhs
 755                         -- [Andy] added, Jun 95
 756
 757 {- Reinstated AJG Jun 95; This is needed
 758     --example that does not (currently) work
 759     --without this extention
 760
 761     --let f = g x
 762     --in
 763     --  case <exp> of
 764     --     True -> h i f
 765     --     False -> f
 766     --  ==>
 767     --  case <exp> of
 768     --     True -> h i f
 769     --     False -> g x
 770 -}
 771 {- OLD:
 772    Omitted SLPJ Feb 95; should, I claim, be unnecessary
 773         -- is_really_small looks for things like f a b c
 774         -- but making sure there are not *too* many arguments.
 775         -- (This is brought to you by *ANDY* Magic Constants, Inc.)
 776     is_really_small
 777       = case collectArgs new_rhs of
 778           (Var _, _, _, xs) -> length xs < 10
 779           _ -> False
 780 -}
 781 \end{code}
 782
 783 \begin{code}
 784 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
 785
 786 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
 787   | not (isLocallyDefined var)  -- Imported, so look inside the id
 788   = getIdUnfolding var
 789
 790   | otherwise                   -- Locally defined, so look in the envt.
 791                                 -- There'll be nothing inside the Id.
 792   = lookup_unfold_env unfold_env var
 793 \end{code}
 794
 795 We need to remove any @GenForm@ bindings from the UnfoldEnv for
 796 the RHS of an Id which has an INLINE pragma.
 797
 798 \begin{code}
 799 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
 800
 801 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 802   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 803   where
 804     new_unfold_env = null_unfold_env
 805         -- This version is really simple.  INLINEd things are going to
 806         -- be inlined wherever they are used, and then all the
 807         -- UnfoldEnv stuff will take effect.  Meanwhile, there isn't
 808         -- much point in doing anything to the as-yet-un-INLINEd rhs.
 809
 810         -- Andy disagrees! Example:
 811         --      all xs = foldr (&&) True xs
 812         --      any p = all . map p  {-# INLINE any #-}
 813         --
 814         -- Problem: any won't get deforested, and so if it's exported and
 815         -- the importer doesn't use the inlining, (eg passes it as an arg)
 816         -- then we won't get deforestation at all.
 817         --
 818         -- So he'd like not to filter the unfold env at all.  But that's a disaster:
 819         -- Suppose we have:
 820         --
 821         -- let f = \pq -> BIG
 822         -- in
 823         -- let g = \y -> f y y
 824         --     {-# INLINE g #-}
 825         -- in ...g...g...g...g...g...
 826         --
 827         -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 828         -- and thence copied multiple times when g is inlined.
 829 \end{code}
 830
 831 ======================
 832
 833 In @lookForConstructor@ we used (before Apr 94) to have a special case
 834 for nullary constructors:
 835
 836 \begin{verbatim}
 837   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 838         -- let
 839         --        a = leInt#! p q
 840         -- in
 841         -- case a of
 842         --    True  -> ...
 843         --    False -> False
 844         --
 845         -- Here the False in the second case will get replace by "a", hardly
 846         -- a good idea
 847     Nothing
 848 \end{verbatim}
 849
 850 but now we only do constructor re-use in let-bindings the special
 851 case isn't necessary any more.
 852
 853 \begin{code}
 854 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
 855   = lookup_conapp unfold_env con args
 856 \end{code}