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                           nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
  62                           addOneToIdEnv, modifyIdEnv,
  63                           IdEnv(..), IdSet(..), GenId )
  64 import IdInfo           ( StrictnessInfo )
  65 import Literal          ( isNoRepLit, Literal{-instances-} )
  66 import Outputable       ( Outputable(..){-instances-} )
  67 import PprCore          -- various instances
  68 import PprStyle         ( PprStyle(..) )
  69 import PprType          ( GenType, GenTyVar )
  70 import Pretty
  71 import Type             ( getAppDataTyCon )
  72 import TyVar            ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
  73                           growTyVarEnvList,
  74                           TyVarEnv(..), GenTyVar )
  75 import Unique           ( Unique )
  76 import UniqSet          -- lots of things
  77 import Usage            ( UVar(..), GenUsage{-instances-} )
  78 import Util             ( zipEqual, panic, assertPanic )
  79
  80 type TypeEnv = TyVarEnv Type
  81 addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)"
  82 applyTypeEnvToId = panic "applyTypeEnvToId (SimplEnv)"
  83 applyTypeEnvToTy = panic "applyTypeEnvToTy (SimplEnv)"
  84 bottomIsGuaranteed = panic "bottomIsGuaranteed (SimplEnv)"
  85 cmpType = panic "cmpType (SimplEnv)"
  86 exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)"
  87 lookupDirectlyUFM = panic "lookupDirectlyUFM (SimplEnv)"
  88 manifestlyWHNF = panic "manifestlyWHNF (SimplEnv)"
  89 occurAnalyseExpr = panic "occurAnalyseExpr (SimplEnv)"
  90 oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
  91 oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
  92 simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
  93 uNFOLDING_CREATION_THRESHOLD = panic "uNFOLDING_CREATION_THRESHOLD (SimplEnv)"
  94 ufmToList = panic "ufmToList (SimplEnv)"
  95 \end{code}
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsection[Simplify-types]{Type declarations}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsubsection{The @SimplEnv@ type}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110
 111 INVARIANT: we assume {\em no shadowing}.  (ToDo: How can we ASSERT
 112 this? WDP 94/06) This allows us to neglect keeping everything paired
 113 with its static environment.
 114
 115 The environment contains bindings for all
 116         {\em in-scope,}
 117         {\em locally-defined}
 118 things.
 119
 120 For such things, any unfolding is found in the environment, not in the
 121 Id.  Unfoldings in the Id itself are used only for imported things
 122 (otherwise we get trouble because we have to simplify the unfoldings
 123 inside the Ids, etc.).
 124
 125 \begin{code}
 126 data SimplEnv
 127   = SimplEnv
 128         SwitchChecker
 129
 130         EnclosingCcDetails -- the enclosing cost-centre (when profiling)
 131
 132         InTypeEnv       -- For cloning types
 133                         -- Domain is all in-scope type variables
 134
 135         InIdEnv         -- IdEnv
 136                         -- Domain is
 137                         --      *all*
 138                         --      *in-scope*,
 139                         --      *locally-defined*
 140                         --      *InIds*
 141                         -- (Could omit the exported top-level guys,
 142                         -- since their names mustn't change; and ditto
 143                         -- the non-exported top-level guys which you
 144                         -- don't want to macro-expand, since their
 145                         -- names need not change.)
 146                         --
 147                         -- Starts off empty
 148
 149         UnfoldEnv       -- Domain is any *OutIds*, including imports
 150                         -- where we know something more than the
 151                         -- interface file tells about their value (see
 152                         -- below)
 153
 154 nullSimplEnv :: SwitchChecker -> SimplEnv
 155
 156 nullSimplEnv sw_chkr
 157   = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
 158
 159 pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
 160   = ppAboves [
 161         ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env,
 162         ppSP, ppStr "** Id Env ** ?????????",
 163 --      ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ],
 164         ppSP, ppStr "** Unfold Env **",
 165         ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ]
 166     ]
 167   where
 168     pp_id_entry (v, idval)
 169       = ppCat [ppr PprDebug v, ppStr "=>",
 170                case idval of
 171                  InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
 172                  ItsAnAtom a    -> ppCat [ppStr "Atom:", ppr PprDebug a]
 173               ]
 174
 175     pp_uf_entry (UnfoldItem v form encl_cc)
 176       = ppCat [ppr PprDebug v, ppStr "=>",
 177                case form of
 178                  NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
 179                  LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
 180                  OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
 181                                                                [ppr PprDebug l | l <- ls]]
 182                  ConForm c a     -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
 183                  OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
 184                                                               [ppr PprDebug c | c <- cs]]
 185                  GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w,
 186                                                         ppr PprDebug g, ppr PprDebug e]
 187                  MagicForm s _   -> ppCat [ppStr "Magic:", ppr PprDebug s]
 188               ]
 189 \end{code}
 190
 191 %************************************************************************
 192 %*                                                                      *
 193 \subsubsection{The @IdVal@ type (for the ``IdEnv'')}
 194 %*                                                                      *
 195 %************************************************************************
 196
 197 The unfoldings for imported things are mostly kept within the Id
 198 itself; nevertheless, they {\em can} get into the @UnfoldEnv@.  For
 199 example, suppose \tr{x} is imported, and we have
 200 \begin{verbatim}
 201         case x of
 202           (p,q) -> <body>
 203 \end{verbatim}
 204 Then within \tr{<body>}, we know that \tr{x} is a pair with components
 205 \tr{p} and \tr{q}.
 206
 207 \begin{code}
 208 type InIdEnv = IdEnv IdVal      -- Maps InIds to their value
 209
 210 data IdVal
 211   = InlineIt InIdEnv InTypeEnv InExpr
 212                 -- No binding of the Id is left;
 213                 -- You *have* to replace any occurences
 214                 -- of the id with this expression.
 215                 -- Rather like a macro, really
 216                 -- NB: the InIdEnv/InTypeEnv is necessary to prevent
 217                 -- name caputure. Consider:
 218                 --      let y = ...
 219                 --          x = ...y...
 220                 --          y = ...
 221                 --      in ...x...
 222                 -- If x gets an InlineIt, we must remember
 223                 -- the correct binding for y.
 224
 225   | ItsAnAtom OutArg    -- Used either (a) to record the cloned Id
 226                         -- or (b) if the orig defn is a let-binding, and
 227                         -- the RHS of the let simplifies to an atom,
 228                         -- we just bind the variable to that atom, and
 229                         -- elide the let.
 230 \end{code}
 231
 232 %************************************************************************
 233 %*                                                                      *
 234 \subsubsection{The @UnfoldEnv@ type}
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 The @UnfoldEnv@ contains information about the value of some of the
 239 in-scope identifiers.  It obeys the following invariant:
 240
 241         If the @UnfoldEnv@ contains information, it is safe to use it!
 242
 243 In particular, if the @UnfoldEnv@ contains details of an unfolding of
 244 an Id, then it's safe to use the unfolding.  If, for example, the Id
 245 is used many times, then its unfolding won't be put in the UnfoldEnv
 246 at all.
 247
 248 The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
 249 because (a)~it's small, and (b)~we need to search its {\em range} as
 250 well as its domain.
 251
 252 \begin{code}
 253 data UnfoldItem -- a glorified triple...
 254   = UnfoldItem  OutId                   -- key: used in lookForConstructor
 255                 UnfoldingDetails        -- for that Id
 256                 EnclosingCcDetails      -- so that if we do an unfolding,
 257                                         -- we can "wrap" it in the CC
 258                                         -- that was in force.
 259
 260 data UnfoldConApp -- yet another glorified triple
 261   = UCA         OutId                   -- same fields as ConForm
 262                 [OutArg]
 263
 264 data UnfoldEnv  -- yup, a glorified triple...
 265   = UFE         (IdEnv UnfoldItem)      -- Maps an OutId => its UnfoldItem
 266                 IdSet                   -- The Ids in the domain of the env
 267                                         -- which have details (GenForm True ...)
 268                                         -- i.e., they claim they are duplicatable.
 269                                         -- These are the ones we have to worry
 270                                         -- about when adding new items to the
 271                                         -- unfold env.
 272                 (FiniteMap UnfoldConApp OutId)
 273                                         -- Maps applications of constructors (to
 274                                         -- types & atoms) back to OutIds that are
 275                                         -- bound to them; i.e., this is a reversed
 276                                         -- mapping for (part of) the main IdEnv
 277                                         -- (1st part of UFE)
 278
 279 null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
 280 \end{code}
 281
 282 The @UnfoldEnv@ type.  We expect on the whole that an @UnfoldEnv@ will
 283 be small, because it contains bindings only for those things whose
 284 form or unfolding is known.  Basically it maps @Id@ to their
 285 @UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
 286 need to search it associatively, to look for @Id@s which have a given
 287 constructor form.
 288
 289 We implement it with @IdEnvs@, possibly overkill, but sometimes these
 290 things silently grow quite big....  Here are some local functions used
 291 elsewhere in the module:
 292
 293 \begin{code}
 294 grow_unfold_env   :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
 295 lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
 296 lookup_unfold_env_encl_cc
 297                   :: UnfoldEnv -> OutId -> EnclosingCcDetails
 298
 299 grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
 300
 301 grow_unfold_env (UFE u_env interesting_ids con_apps) id
 302                 uf_details@(GenForm True _ _ _) encl_cc
 303     -- Only interested in Ids which have a "dangerous" unfolding; that is
 304     -- one that claims to have a single occurrence.
 305   = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
 306         (interesting_ids `unionUniqSets` singletonUniqSet id)
 307         con_apps
 308
 309 grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
 310   = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
 311         interesting_ids
 312         new_con_apps
 313   where
 314     new_con_apps
 315       = case uf_details of
 316           ConForm con vargs
 317             -> case (lookupFM con_apps entry) of
 318                  Just _  -> con_apps -- unchanged; we hang onto what we have
 319                  Nothing -> addToFM con_apps entry id
 320             where
 321               entry = UCA con vargs
 322
 323           not_a_constructor -> con_apps -- unchanged
 324
 325 addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
 326   = ASSERT(not (any constructor_form_in_those extra_items))
 327     -- otherwise, we'd need to change con_apps
 328     UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
 329   where
 330     constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
 331     constructor_form_in_those _ = False
 332
 333 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
 334
 335 get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
 336
 337 foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
 338   = UFE (foldr fun u_env stuff) interesting_ids con_apps
 339
 340 lookup_unfold_env (UFE u_env _ _) id
 341   = case (lookupIdEnv u_env id) of
 342       Nothing                  -> NoUnfoldingDetails
 343       Just (UnfoldItem _ uf _) -> uf
 344
 345 lookup_unfold_env_encl_cc (UFE u_env _ _) id
 346   = case (lookupIdEnv u_env id) of
 347       Nothing                       -> NoEnclosingCcDetails
 348       Just (UnfoldItem _ _ encl_cc) -> encl_cc
 349
 350 lookup_conapp (UFE _ _ con_apps) con args
 351   = lookupFM con_apps (UCA con args)
 352
 353 modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
 354   = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
 355
 356 -- If the current binding claims to be a "unique" one, then
 357 -- we modify it.
 358 modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
 359
 360 modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
 361   = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
 362 \end{code}
 363
 364 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 365 it, so we can use it for a @FiniteMap@ key.
 366 \begin{code}
 367 instance Eq  UnfoldConApp where
 368     a == b = case cmp_app a b of { EQ_ -> True;   _ -> False }
 369     a /= b = case cmp_app a b of { EQ_ -> False;  _ -> True  }
 370
 371 instance Ord UnfoldConApp where
 372     a <= b = case cmp_app a b of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 373     a <  b = case cmp_app a b of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 374     a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 375     a >  b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 376     _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 377
 378 instance Ord3 UnfoldConApp where
 379     cmp = cmp_app
 380
 381 cmp_app (UCA c1 as1) (UCA c2 as2)
 382   = case (c1 `cmp` c2) of
 383       LT_ -> LT_
 384       GT_ -> GT_
 385       _   -> cmp_lists cmp_atom as1 as2
 386   where
 387     cmp_lists cmp_item []     []     = EQ_
 388     cmp_lists cmp_item (x:xs) []     = GT_
 389     cmp_lists cmp_item []     (y:ys) = LT_
 390     cmp_lists cmp_item (x:xs) (y:ys)
 391       = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
 392
 393     cmp_atom (VarArg x) (VarArg y) = x `cmp` y
 394     cmp_atom (VarArg _) _                = LT_
 395     cmp_atom (LitArg x) (LitArg y)
 396       = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
 397     cmp_atom (LitArg _) _                = GT_
 398 \end{code}
 399
 400 %************************************************************************
 401 %*                                                                      *
 402 \subsubsection{The @EnclosingCcDetails@ type}
 403 %*                                                                      *
 404 %************************************************************************
 405
 406 \begin{code}
 407 data EnclosingCcDetails
 408   = NoEnclosingCcDetails
 409   | EnclosingCC     CostCentre
 410 \end{code}
 411
 412 %************************************************************************
 413 %*                                                                      *
 414 \subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
 415 %*                                                                      *
 416 %************************************************************************
 417
 418 \begin{code}
 419 type InId      = Id                     -- Not yet cloned
 420 type InBinder  = (InId, BinderInfo)
 421 type InType    = Type                   -- Ditto
 422 type InBinding = SimplifiableCoreBinding
 423 type InExpr    = SimplifiableCoreExpr
 424 type InAlts    = SimplifiableCoreCaseAlts
 425 type InDefault = SimplifiableCoreCaseDefault
 426 type InArg     = SimplifiableCoreArg
 427
 428 type OutId      = Id                    -- Cloned
 429 type OutBinder  = Id
 430 type OutType    = Type                  -- Cloned
 431 type OutBinding = CoreBinding
 432 type OutExpr    = CoreExpr
 433 type OutAlts    = CoreCaseAlts
 434 type OutDefault = CoreCaseDefault
 435 type OutArg     = CoreArg
 436
 437 \end{code}
 438
 439 \begin{code}
 440 type SwitchChecker = SimplifierSwitch -> SwitchResult
 441 \end{code}
 442
 443 %************************************************************************
 444 %*                                                                      *
 445 \subsection{@SimplEnv@ handling}
 446 %*                                                                      *
 447 %************************************************************************
 448
 449 %************************************************************************
 450 %*                                                                      *
 451 \subsubsection{Command-line switches}
 452 %*                                                                      *
 453 %************************************************************************
 454
 455 \begin{code}
 456 getSwitchChecker :: SimplEnv -> SwitchChecker
 457 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
 458
 459 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
 460 switchIsSet (SimplEnv chkr _ _ _ _) switch
 461   = switchIsOn chkr switch
 462 \end{code}
 463
 464 %************************************************************************
 465 %*                                                                      *
 466 \subsubsection{The ``enclosing cost-centre''}
 467 %*                                                                      *
 468 %************************************************************************
 469
 470 \begin{code}
 471 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
 472
 473 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
 474   = SimplEnv chkr encl_cc ty_env id_env unfold_env
 475 \end{code}
 476
 477 %************************************************************************
 478 %*                                                                      *
 479 \subsubsection{The @TypeEnv@ part}
 480 %*                                                                      *
 481 %************************************************************************
 482
 483 \begin{code}
 484 type InTypeEnv = TypeEnv        -- Maps InTyVars to OutTypes
 485
 486 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
 487 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
 488   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 489   where
 490     new_ty_env = addOneToTyVarEnv ty_env tyvar ty
 491
 492 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
 493 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
 494   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 495   where
 496     new_ty_env = growTyVarEnvList ty_env pairs
 497
 498 simplTy     (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
 499
 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}