ghc/compiler/simplCore/SimplEnv.lhs

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