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