ghc/compiler/simplCore/SimplEnv.lhs

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