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 Outputable       ( Outputable(..){-instances-} )
  68 import PprCore          -- various instances
  69 import PprStyle         ( PprStyle(..) )
  70 import PprType          ( GenType, GenTyVar )
  71 import Pretty
  72 import Type             ( getAppDataTyCon, applyTypeEnvToTy )
  73 import TyVar            ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
  74                           growTyVarEnvList,
  75                           TyVarEnv(..), GenTyVar{-instance Eq-}
  76                         )
  77 import Unique           ( Unique{-instance Outputable-} )
  78 import UniqSet          -- lots of things
  79 import Usage            ( UVar(..), GenUsage{-instances-} )
  80 import Util             ( zipEqual, panic, assertPanic )
  81
  82 type TypeEnv = TyVarEnv Type
  83 addToUFM_Directly = panic "addToUFM_Directly (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         (addOneToUniqSet interesting_ids 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 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
 500 \end{code}
 501
 502 @replaceInEnvs@ is used to install saved type and id envs
 503 when pulling an un-simplified expression out of the environment, which
 504 was saved with its environments.
 505
 506 \begin{code}
 507 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
 508
 509 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
 510
 511 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 512               (new_ty_env, new_id_env)
 513   = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
 514 \end{code}
 515
 516 %************************************************************************
 517 %*                                                                      *
 518 \subsubsection{The ``Id env'' part}
 519 %*                                                                      *
 520 %************************************************************************
 521
 522 \begin{code}
 523 extendIdEnvWithAtom
 524         :: SimplEnv
 525         -> InBinder -> OutArg
 526         -> SimplEnv
 527
 528 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
 529   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 530   where
 531     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 532
 533 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 534             (in_id, occ_info) atom@(VarArg out_id)
 535   = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
 536   where
 537     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 538
 539     new_unfold_env = modify_unfold_env
 540                         unfold_env
 541                         (modifyItem ok_to_dup occ_info)
 542                         out_id
 543                 -- Modify binding for in_id
 544                 -- NO! modify out_id, because its the info on the
 545                 -- atom that interest's us.
 546
 547     ok_to_dup    = switchIsOn chkr SimplOkToDupCode
 548
 549 extendIdEnvWithAtomList
 550         :: SimplEnv
 551         -> [(InBinder, OutArg)]
 552         -> SimplEnv
 553 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 554
 555 extendIdEnvWithInlining
 556         :: SimplEnv             -- The Env to modify
 557         -> SimplEnv             -- The Env to record in the inlining.  Usually the
 558                                 -- same as the previous one, except in the recursive case
 559         -> InBinder -> InExpr
 560         -> SimplEnv
 561
 562 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env        id_env        unfold_env)
 563                         ~(SimplEnv _   _       inline_ty_env inline_id_env _         )
 564                         (in_id,occ_info)
 565                         expr
 566   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 567   where
 568     new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
 569
 570 extendIdEnvWithClone
 571         :: SimplEnv
 572         -> InBinder     -- Old binder; binderinfo ignored
 573         -> OutId        -- Its new clone, as an Id
 574         -> SimplEnv
 575
 576 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 577         (in_id,_) out_id
 578   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 579   where
 580     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
 581
 582 extendIdEnvWithClones   -- Like extendIdEnvWithClone
 583         :: SimplEnv
 584         -> [InBinder]
 585         -> [OutId]
 586         -> SimplEnv
 587
 588 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 589         in_binders out_ids
 590   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 591   where
 592     new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
 593     in_ids     = [id | (id,_) <- in_binders]
 594     out_vals   = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
 595
 596 lookupId :: SimplEnv -> Id -> Maybe IdVal
 597
 598 lookupId (SimplEnv _ _ _ id_env _) id
 599 #ifndef DEBUG
 600   = lookupIdEnv id_env id
 601 #else
 602   = case (lookupIdEnv id_env id) of
 603       xxx@(Just _) -> xxx
 604       xxx          -> --false!: ASSERT(not (isLocallyDefined id))
 605                       xxx
 606 #endif
 607 \end{code}
 608
 609 %************************************************************************
 610 %*                                                                      *
 611 \subsubsection{The @UnfoldEnv@}
 612 %*                                                                      *
 613 %************************************************************************
 614
 615 \begin{code}
 616 extendUnfoldEnvGivenFormDetails
 617         :: SimplEnv
 618         -> OutId
 619         -> UnfoldingDetails
 620         -> SimplEnv
 621
 622 extendUnfoldEnvGivenFormDetails
 623         env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 624         id details
 625   = case details of
 626       NoUnfoldingDetails -> env
 627       good_details       -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 628         where
 629           new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
 630
 631 extendUnfoldEnvGivenConstructor -- specialised variant
 632         :: SimplEnv
 633         -> OutId                -- bind this to...
 634         -> Id -> [OutId]        -- "con <tys-to-be-invented> args"
 635         -> SimplEnv
 636
 637 extendUnfoldEnvGivenConstructor env var con args
 638   = let
 639         -- conjure up the types to which the con should be applied
 640         scrut_ty        = idType var
 641         (_, ty_args, _) = getAppDataTyCon scrut_ty
 642     in
 643     extendUnfoldEnvGivenFormDetails
 644       env var (ConForm con (map VarArg args))
 645 \end{code}
 646
 647
 648 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 649 of a new binding.  There is a horrid case we have to take care about,
 650 due to Andr\'e Santos:
 651 @
 652     type Array_type b   = Array Int b;
 653     type Descr_type     = (Int,Int);
 654
 655     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 656     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 657
 658     f_iaamain a_xs=
 659         let {
 660             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 661             f_aareorder a_index a_ar=
 662                 let {
 663                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 664                  } in  tabulate f_aareorder' (bounds a_ar);
 665             r_index=tabulate ((+) 1) (1,1);
 666             arr    = listArray (1,1) a_xs;
 667             arg    = f_aareorder r_index arr
 668          } in  elems arg
 669 @
 670 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 671 @
 672         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 673                in tabulate f_aareorder' (bounds arr)
 674 @
 675 Note that r_index is not inlined, because it was bound to a_index which
 676 occurs inside a lambda.
 677
 678 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 679 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 680 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 681 will get inlined inside the lambda.  AARGH.
 682
 683 Solution: when we occurrence-analyse the new RHS we have to go back
 684 and modify the info recorded in the UnfoldEnv for the free vars
 685 of the RHS.  In the example we'd go back and record that r_index is now used
 686 inside a lambda.
 687
 688 \begin{code}
 689 extendUnfoldEnvGivenRhs
 690         :: SimplEnv
 691         -> InBinder
 692         -> OutId        -- Note: *must* be an "out" Id (post-cloning)
 693         -> OutExpr      -- Its rhs (*simplified*)
 694         -> SimplEnv
 695
 696 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 697                         binder@(_,occ_info) out_id rhs
 698   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 699   where
 700         -- Occurrence-analyse the RHS
 701     (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
 702
 703     interesting_fvs = get_interesting_ids unfold_env
 704
 705         -- Compute unfolding details
 706     details = case rhs of
 707                 Var v                      -> panic "Vars already dealt with"
 708                 Lit lit | isNoRepLit lit -> LitForm lit
 709                           | otherwise      -> panic "non-noRep Lits already dealt with"
 710
 711                 Con con args               -> ConForm con args
 712
 713                 other -> mkGenForm ok_to_dup occ_info
 714                                    (mkFormSummary (getIdStrictness out_id) rhs)
 715                                    template guidance
 716
 717         -- Compute resulting unfold env
 718     new_unfold_env = case details of
 719                         NoUnfoldingDetails      -> unfold_env
 720                         GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
 721                         other                   -> unfold_env1
 722
 723         -- Add unfolding to unfold env
 724     unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
 725
 726         -- Modify unfoldings of free vars of rhs, based on their
 727         -- occurrence info in the rhs [see notes above]
 728     unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
 729
 730     modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
 731     modify (u, occ_info) env
 732       = case (lookupDirectlyUFM env u) of
 733           Nothing -> env -- ToDo: can this happen?
 734           Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
 735
 736         -- Compute unfolding guidance
 737     guidance = if simplIdWantsToBeINLINEd out_id env
 738                then UnfoldAlways
 739                else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
 740
 741     bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
 742                       Nothing -> uNFOLDING_CREATION_THRESHOLD
 743                       Just xx -> xx
 744
 745     ok_to_dup     = switchIsOn chkr SimplOkToDupCode
 746                         || exprSmallEnoughToDup rhs
 747                         -- [Andy] added, Jun 95
 748
 749 {- Reinstated AJG Jun 95; This is needed
 750     --example that does not (currently) work
 751     --without this extention
 752
 753     --let f = g x
 754     --in
 755     --  case <exp> of
 756     --     True -> h i f
 757     --     False -> f
 758     --  ==>
 759     --  case <exp> of
 760     --     True -> h i f
 761     --     False -> g x
 762 -}
 763 {- OLD:
 764    Omitted SLPJ Feb 95; should, I claim, be unnecessary
 765         -- is_really_small looks for things like f a b c
 766         -- but making sure there are not *too* many arguments.
 767         -- (This is brought to you by *ANDY* Magic Constants, Inc.)
 768     is_really_small
 769       = case collectArgs new_rhs of
 770           (Var _, _, _, xs) -> length xs < 10
 771           _ -> False
 772 -}
 773 \end{code}
 774
 775 \begin{code}
 776 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
 777
 778 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
 779   | not (isLocallyDefined var)  -- Imported, so look inside the id
 780   = getIdUnfolding var
 781
 782   | otherwise                   -- Locally defined, so look in the envt.
 783                                 -- There'll be nothing inside the Id.
 784   = lookup_unfold_env unfold_env var
 785 \end{code}
 786
 787 We need to remove any @GenForm@ bindings from the UnfoldEnv for
 788 the RHS of an Id which has an INLINE pragma.
 789
 790 \begin{code}
 791 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
 792
 793 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 794   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 795   where
 796     new_unfold_env = null_unfold_env
 797         -- This version is really simple.  INLINEd things are going to
 798         -- be inlined wherever they are used, and then all the
 799         -- UnfoldEnv stuff will take effect.  Meanwhile, there isn't
 800         -- much point in doing anything to the as-yet-un-INLINEd rhs.
 801
 802         -- Andy disagrees! Example:
 803         --      all xs = foldr (&&) True xs
 804         --      any p = all . map p  {-# INLINE any #-}
 805         --
 806         -- Problem: any won't get deforested, and so if it's exported and
 807         -- the importer doesn't use the inlining, (eg passes it as an arg)
 808         -- then we won't get deforestation at all.
 809         --
 810         -- So he'd like not to filter the unfold env at all.  But that's a disaster:
 811         -- Suppose we have:
 812         --
 813         -- let f = \pq -> BIG
 814         -- in
 815         -- let g = \y -> f y y
 816         --     {-# INLINE g #-}
 817         -- in ...g...g...g...g...g...
 818         --
 819         -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 820         -- and thence copied multiple times when g is inlined.
 821 \end{code}
 822
 823 ======================
 824
 825 In @lookForConstructor@ we used (before Apr 94) to have a special case
 826 for nullary constructors:
 827
 828 \begin{verbatim}
 829   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 830         -- let
 831         --        a = leInt#! p q
 832         -- in
 833         -- case a of
 834         --    True  -> ...
 835         --    False -> False
 836         --
 837         -- Here the False in the second case will get replace by "a", hardly
 838         -- a good idea
 839     Nothing
 840 \end{verbatim}
 841
 842 but now we only do constructor re-use in let-bindings the special
 843 case isn't necessary any more.
 844
 845 \begin{code}
 846 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
 847   = lookup_conapp unfold_env con args
 848 \end{code}