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