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         SYN_IE(SwitchChecker),
  35         SimplEnv, EnclosingCcDetails(..),
  36         SYN_IE(InIdEnv), IdVal(..), SYN_IE(InTypeEnv),
  37         UnfoldEnv, UnfoldItem, UnfoldConApp,
  38
  39         SYN_IE(InId),  SYN_IE(InBinder),  SYN_IE(InBinding),  SYN_IE(InType),
  40         SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType),
  41
  42         SYN_IE(InExpr),  SYN_IE(InAlts),  SYN_IE(InDefault),  SYN_IE(InArg),
  43         SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(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                           SYN_IE(IdEnv), SYN_IE(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, addOneToTyVarEnv, growTyVarEnvList,
  79                           SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
  80                         )
  81 import Unique           ( Unique{-instance Outputable-} )
  82 import UniqFM           ( addToUFM_Directly, lookupUFM_Directly, delFromUFM_Directly,
  83                           delFromUFM, ufmToList
  84                         )
  85 --import UniqSet                -- lots of things
  86 import Usage            ( SYN_IE(UVar), GenUsage{-instances-} )
  87 import Util             ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
  88
  89 type TypeEnv = TyVarEnv Type
  90 cmpType = panic "cmpType (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                  OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
 176                                                                [ppr PprDebug l | l <- ls]]
 177                  OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
 178                                                               [ppr PprDebug c | c <- cs]]
 179                  GenForm w e g -> ppCat [ppStr "UF:",   ppr PprDebug w,
 180                                                         ppr PprDebug g, ppr PprDebug e]
 181                  MagicForm s _   -> ppCat [ppStr "Magic:", ppr PprDebug s]
 182               ]
 183 \end{code}
 184
 185 %************************************************************************
 186 %*                                                                      *
 187 \subsubsection{The @IdVal@ type (for the ``IdEnv'')}
 188 %*                                                                      *
 189 %************************************************************************
 190
 191 The unfoldings for imported things are mostly kept within the Id
 192 itself; nevertheless, they {\em can} get into the @UnfoldEnv@.  For
 193 example, suppose \tr{x} is imported, and we have
 194 \begin{verbatim}
 195         case x of
 196           (p,q) -> <body>
 197 \end{verbatim}
 198 Then within \tr{<body>}, we know that \tr{x} is a pair with components
 199 \tr{p} and \tr{q}.
 200
 201 \begin{code}
 202 type InIdEnv = IdEnv IdVal      -- Maps InIds to their value
 203
 204 data IdVal
 205   = InlineIt InIdEnv InTypeEnv InExpr
 206                 -- No binding of the Id is left;
 207                 -- You *have* to replace any occurences
 208                 -- of the id with this expression.
 209                 -- Rather like a macro, really
 210                 -- NB: the InIdEnv/InTypeEnv is necessary to prevent
 211                 -- name caputure. Consider:
 212                 --      let y = ...
 213                 --          x = ...y...
 214                 --          y = ...
 215                 --      in ...x...
 216                 -- If x gets an InlineIt, we must remember
 217                 -- the correct binding for y.
 218
 219   | ItsAnAtom OutArg    -- Used either (a) to record the cloned Id
 220                         -- or (b) if the orig defn is a let-binding, and
 221                         -- the RHS of the let simplifies to an atom,
 222                         -- we just bind the variable to that atom, and
 223                         -- elide the let.
 224 \end{code}
 225
 226 %************************************************************************
 227 %*                                                                      *
 228 \subsubsection{The @UnfoldEnv@ type}
 229 %*                                                                      *
 230 %************************************************************************
 231
 232 The @UnfoldEnv@ contains information about the value of some of the
 233 in-scope identifiers.  It obeys the following invariant:
 234
 235         If the @UnfoldEnv@ contains information, it is safe to use it!
 236
 237 In particular, if the @UnfoldEnv@ contains details of an unfolding of
 238 an Id, then it's safe to use the unfolding.  If, for example, the Id
 239 is used many times, then its unfolding won't be put in the UnfoldEnv
 240 at all.
 241
 242 The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
 243 because (a)~it's small, and (b)~we need to search its {\em range} as
 244 well as its domain.
 245
 246 \begin{code}
 247 data UnfoldItem -- a glorified triple...
 248   = UnfoldItem  OutId                   -- key: used in lookForConstructor
 249                 UnfoldingDetails        -- for that Id
 250                 EnclosingCcDetails      -- so that if we do an unfolding,
 251                                         -- we can "wrap" it in the CC
 252                                         -- that was in force.
 253
 254 data UnfoldConApp -- yet another glorified pair
 255   = UCA         OutId                   -- data constructor
 256                 [OutArg]                -- *value* arguments; see use below
 257
 258 data UnfoldEnv  -- yup, a glorified triple...
 259   = UFE         (IdEnv UnfoldItem)      -- Maps an OutId => its UnfoldItem
 260
 261                 (IdEnv (Id,BinderInfo)) -- Occurrence info for some (but not necessarily all)
 262                                         -- in-scope ids.  The "Id" part is just so that
 263                                         -- we can recover the domain of the mapping, which
 264                                         -- IdEnvs don't allow directly.
 265                                         --
 266                                         -- Anything that isn't in here
 267                                         -- should be assumed to occur many times.
 268                                         -- The things in here all occur once, and the
 269                                         -- binder-info tells about whether that "once"
 270                                         -- is inside a lambda, or perhaps once in each branch
 271                                         -- of a case etc.
 272                                         -- We keep this info so we can modify it when
 273                                         -- something changes.
 274
 275                 (FiniteMap UnfoldConApp [([Type], OutId)])
 276                                         -- Maps applications of constructors (to
 277                                         -- value atoms) back to an association list
 278                                         -- that says "if the constructor was applied
 279                                         -- to one of these lists-of-Types, then
 280                                         -- this OutId is your man (in a non-gender-specific
 281                                         -- sense)".  I.e., this is a reversed
 282                                         -- mapping for (part of) the main IdEnv
 283                                         -- (1st part of UFE)
 284
 285 null_unfold_env = UFE nullIdEnv nullIdEnv emptyFM
 286 \end{code}
 287
 288 The @UnfoldEnv@ type.  We expect on the whole that an @UnfoldEnv@ will
 289 be small, because it contains bindings only for those things whose
 290 form or unfolding is known.  Basically it maps @Id@ to their
 291 @UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
 292 need to search it associatively, to look for @Id@s which have a given
 293 constructor form.
 294
 295 We implement it with @IdEnvs@, possibly overkill, but sometimes these
 296 things silently grow quite big....  Here are some local functions used
 297 elsewhere in the module:
 298
 299 \begin{code}
 300 grow_unfold_env   :: UnfoldEnv -> OutId -> BinderInfo -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
 301 lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
 302 lookup_unfold_env_encl_cc
 303                   :: UnfoldEnv -> OutId -> EnclosingCcDetails
 304
 305 grow_unfold_env full_u_env _ _ NoUnfoldingDetails _ = full_u_env
 306
 307 grow_unfold_env (UFE u_env occ_env con_apps) id occ_info uf_details encl_cc
 308   = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
 309         new_occ_env
 310         new_con_apps
 311   where
 312     new_occ_env = modify_occ_info occ_env id occ_info
 313
 314     new_con_apps
 315       = case uf_details of
 316           GenForm WhnfForm (Con con args) UnfoldAlways -> snd (lookup_conapp_help con_apps con args id)
 317           not_a_constructor -> con_apps -- unchanged
 318
 319 addto_unfold_env (UFE u_env occ_env con_apps) extra_items
 320   = ASSERT(not (any constructor_form_in_those extra_items))
 321     -- otherwise, we'd need to change con_apps
 322     UFE (growIdEnvList u_env extra_items) occ_env con_apps
 323   where
 324     constructor_form_in_those (_, UnfoldItem _ (GenForm WhnfForm (Con _ _) UnfoldAlways) _) = True
 325     constructor_form_in_those _ = False
 326
 327 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
 328
 329 get_interesting_ids (UFE _ occ_env _)
 330   = mkIdSet [ i | (_,(i,_)) <- ufmToList occ_env ]
 331
 332 foldr_occ_env fun (UFE u_env occ_env con_apps) stuff
 333   = UFE u_env (foldr fun occ_env stuff) con_apps
 334
 335 lookup_unfold_env (UFE u_env _ _) id
 336   = case (lookupIdEnv u_env id) of
 337       Nothing                  -> NoUnfoldingDetails
 338       Just (UnfoldItem _ uf _) -> uf
 339
 340 lookup_unfold_env_encl_cc (UFE u_env _ _) id
 341   = case (lookupIdEnv u_env id) of
 342       Nothing                       -> NoEnclosingCcDetails
 343       Just (UnfoldItem _ _ encl_cc) -> encl_cc
 344
 345 lookup_conapp (UFE _ _ con_apps) con args
 346   = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp"))
 347
 348 -- Returns two things; we just fst or snd the one we want:
 349 lookup_conapp_help con_apps con args outid
 350   = case (span notValArg args) of { (ty_args, val_args) ->
 351     let
 352          entry   = UCA con val_args
 353          arg_tys = [ t | TyArg t <- ty_args ]
 354     in
 355     case (lookupFM con_apps entry) of
 356       Nothing -> (Nothing,
 357                  addToFM con_apps entry [(arg_tys, outid)])
 358       Just assocs
 359         -> ASSERT(not (null assocs))
 360            case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of
 361              [o] -> (Just o,
 362                     con_apps) -- unchanged; we hang onto what we have
 363              []  -> (Nothing,
 364                     addToFM con_apps entry ((arg_tys, outid) : assocs))
 365              _   -> panic "grow_unfold_env:dup in assoc list"
 366     }
 367   where
 368     eq_tys ts1 ts2
 369       = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False }
 370
 371     cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types
 372       = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-}
 373
 374 modify_occ_info occ_env id new_occ@(OneOcc _ _ _ _ _)
 375   = modifyIdEnv occ_env (\ (i,o) -> (i, orBinderInfo o new_occ)) id
 376
 377 modify_occ_info occ_env id other_new_occ
 378   =     -- Many or Dead occurrence, just delete from occ_env
 379     delFromUFM occ_env id
 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 (a `cmp` b) of { EQ_ -> True;   _ -> False }
 387     a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
 388
 389 instance Ord UnfoldConApp where
 390     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 391     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 392     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 393     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 394     _tagCmp a b = case (a `cmp` 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) = x `cmp` y
 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 type SwitchChecker = SimplifierSwitch -> SwitchResult
 456 \end{code}
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection{@SimplEnv@ handling}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 %************************************************************************
 465 %*                                                                      *
 466 \subsubsection{Command-line switches}
 467 %*                                                                      *
 468 %************************************************************************
 469
 470 \begin{code}
 471 getSwitchChecker :: SimplEnv -> SwitchChecker
 472 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
 473
 474 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
 475 switchIsSet (SimplEnv chkr _ _ _ _) switch
 476   = switchIsOn chkr switch
 477 \end{code}
 478
 479 %************************************************************************
 480 %*                                                                      *
 481 \subsubsection{The ``enclosing cost-centre''}
 482 %*                                                                      *
 483 %************************************************************************
 484
 485 \begin{code}
 486 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
 487
 488 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
 489   = SimplEnv chkr encl_cc ty_env id_env unfold_env
 490 \end{code}
 491
 492 %************************************************************************
 493 %*                                                                      *
 494 \subsubsection{The @TypeEnv@ part}
 495 %*                                                                      *
 496 %************************************************************************
 497
 498 \begin{code}
 499 type InTypeEnv = TypeEnv        -- Maps InTyVars to OutTypes
 500
 501 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
 502 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
 503   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 504   where
 505     new_ty_env = addOneToTyVarEnv ty_env tyvar ty
 506
 507 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
 508 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
 509   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 510   where
 511     new_ty_env = growTyVarEnvList ty_env pairs
 512
 513 simplTy     (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
 514 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
 515 \end{code}
 516
 517 @replaceInEnvs@ is used to install saved type and id envs
 518 when pulling an un-simplified expression out of the environment, which
 519 was saved with its environments.
 520
 521 \begin{code}
 522 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
 523
 524 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
 525
 526 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 527               (new_ty_env, new_id_env)
 528   = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
 529 \end{code}
 530
 531 %************************************************************************
 532 %*                                                                      *
 533 \subsubsection{The ``Id env'' part}
 534 %*                                                                      *
 535 %************************************************************************
 536
 537 \begin{code}
 538 extendIdEnvWithAtom
 539         :: SimplEnv
 540         -> InBinder -> OutArg{-Val args only, please-}
 541         -> SimplEnv
 542
 543 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 544                     (in_id,occ_info) atom@(LitArg lit)
 545   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 546   where
 547     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 548
 549 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env (UFE u_env occ_env con_apps))
 550                     (in_id, occ_info) atom@(VarArg out_id)
 551   = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
 552   where
 553     new_id_env     = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 554     new_unfold_env = UFE u_env (modify_occ_info occ_env out_id occ_info) con_apps
 555                         -- Modify occ info for out_id
 556
 557 #ifdef DEBUG
 558 extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
 559 #endif
 560
 561 extendIdEnvWithAtomList
 562         :: SimplEnv
 563         -> [(InBinder, OutArg)]
 564         -> SimplEnv
 565 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 566
 567 extendIdEnvWithInlining
 568         :: SimplEnv             -- The Env to modify
 569         -> SimplEnv             -- The Env to record in the inlining.  Usually the
 570                                 -- same as the previous one, except in the recursive case
 571         -> InBinder -> InExpr
 572         -> SimplEnv
 573
 574 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env        id_env        unfold_env)
 575                         ~(SimplEnv _   _       inline_ty_env inline_id_env _         )
 576                         (in_id,occ_info)
 577                         expr
 578   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 579   where
 580     new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
 581
 582 extendIdEnvWithClone
 583         :: SimplEnv
 584         -> InBinder     -- Old binder; binderinfo ignored
 585         -> OutId        -- Its new clone, as an Id
 586         -> SimplEnv
 587
 588 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 589         (in_id,_) out_id
 590   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 591   where
 592     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
 593
 594 extendIdEnvWithClones   -- Like extendIdEnvWithClone
 595         :: SimplEnv
 596         -> [InBinder]
 597         -> [OutId]
 598         -> SimplEnv
 599
 600 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 601         in_binders out_ids
 602   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 603   where
 604     new_id_env = growIdEnvList id_env (zipEqual "extendIdEnvWithClones" in_ids out_vals)
 605     in_ids     = [id | (id,_) <- in_binders]
 606     out_vals   = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
 607
 608 lookupId :: SimplEnv -> Id -> Maybe IdVal
 609
 610 lookupId (SimplEnv _ _ _ id_env _) id
 611 #ifndef DEBUG
 612   = lookupIdEnv id_env id
 613 #else
 614   = case (lookupIdEnv id_env id) of
 615       xxx@(Just _) -> xxx
 616       xxx          -> --false!: ASSERT(not (isLocallyDefined id))
 617                       xxx
 618 #endif
 619 \end{code}
 620
 621 %************************************************************************
 622 %*                                                                      *
 623 \subsubsection{The @UnfoldEnv@}
 624 %*                                                                      *
 625 %************************************************************************
 626
 627 \begin{code}
 628 extendUnfoldEnvGivenFormDetails
 629         :: SimplEnv
 630         -> OutId
 631         -> UnfoldingDetails
 632         -> SimplEnv
 633
 634 extendUnfoldEnvGivenFormDetails
 635         env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 636         id details
 637   = case details of
 638       NoUnfoldingDetails -> env
 639       good_details       -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 640         where
 641           new_unfold_env = grow_unfold_env unfold_env id fake_occ_info good_details encl_cc
 642           fake_occ_info  = {-ToDo!-} ManyOcc 0 -- generally paranoid
 643
 644 extendUnfoldEnvGivenConstructor -- specialised variant
 645         :: SimplEnv
 646         -> OutId                -- bind this to...
 647         -> Id -> [OutId]        -- "con <tys-to-be-invented> args"
 648         -> SimplEnv
 649
 650 extendUnfoldEnvGivenConstructor env var con args
 651   = let
 652         -- conjure up the types to which the con should be applied
 653         scrut_ty        = idType var
 654         (_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty
 655     in
 656     extendUnfoldEnvGivenFormDetails
 657       env var (mkConForm con (map TyArg ty_args ++ map VarArg args))
 658 \end{code}
 659
 660
 661 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 662 of a new binding.  There is a horrid case we have to take care about,
 663 due to Andr\'e Santos:
 664 @
 665     type Array_type b   = Array Int b;
 666     type Descr_type     = (Int,Int);
 667
 668     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 669     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 670
 671     f_iaamain a_xs=
 672         let {
 673             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 674             f_aareorder a_index a_ar=
 675                 let {
 676                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 677                  } in  tabulate f_aareorder' (bounds a_ar);
 678             r_index=tabulate ((+) 1) (1,1);
 679             arr    = listArray (1,1) a_xs;
 680             arg    = f_aareorder r_index arr
 681          } in  elems arg
 682 @
 683 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 684 @
 685         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 686                in tabulate f_aareorder' (bounds arr)
 687 @
 688 Note that r_index is not inlined, because it was bound to a_index which
 689 occurs inside a lambda.
 690
 691 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 692 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 693 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 694 will get inlined inside the lambda.  AARGH.
 695
 696 Solution: when we occurrence-analyse the new RHS we have to go back
 697 and modify the info recorded in the UnfoldEnv for the free vars
 698 of the RHS.  In the example we'd go back and record that r_index is now used
 699 inside a lambda.
 700
 701 \begin{code}
 702 extendUnfoldEnvGivenRhs
 703         :: SimplEnv
 704         -> InBinder
 705         -> OutId        -- Note: *must* be an "out" Id (post-cloning)
 706         -> OutExpr      -- Its rhs (*simplified*)
 707         -> SimplEnv
 708
 709 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 710                         binder@(_,occ_info) out_id rhs
 711   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 712   where
 713         -- Occurrence-analyse the RHS
 714     (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs
 715
 716     interesting_fvs = get_interesting_ids unfold_env   -- Ids in dom of OccEnv
 717
 718         -- Compute unfolding details
 719     details = mkGenForm (mkFormSummary (getIdStrictness out_id) rhs)
 720                         template guidance
 721
 722         -- Compute resulting unfold env
 723     new_unfold_env = case details of
 724                         NoUnfoldingDetails  -> unfold_env
 725                         other               -> unfold_env1
 726
 727         -- Add unfolding to unfold env
 728     unfold_env1 = grow_unfold_env unfold_env out_id occ_info details encl_cc
 729
 730 {- OLD: done in grow_unfold_env
 731         -- Modify unfoldings of free vars of rhs, based on their
 732         -- occurrence info in the rhs [see notes above]
 733     unfold_env2
 734       = foldr_occ_env modify unfold_env1 (ufmToList fv_occ_info)
 735       where
 736         modify :: (Unique, (Id,BinderInfo)) -> IdEnv (Id,BinderInfo) -> IdEnv (Id,BinderInfo)
 737         modify (u, item@(i,occ_info)) env
 738           = if maybeToBool (lookupUFM_Directly env u) then
 739                 -- it occurred before, so now it occurs multiple times;
 740                 -- therefore, *delete* it from the occ(urs once) env.
 741                 delFromUFM_Directly env u
 742
 743             else if not (oneSafeOcc ok_to_dup occ_info) then
 744                 env -- leave it alone
 745             else
 746                 addToUFM_Directly env u item
 747 -}
 748
 749         -- Compute unfolding guidance
 750     guidance = if simplIdWantsToBeINLINEd out_id env
 751                then UnfoldAlways
 752                else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
 753
 754     bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
 755                       Nothing -> uNFOLDING_CREATION_THRESHOLD
 756                       Just xx -> xx
 757
 758     ok_to_dup     = switchIsOn chkr SimplOkToDupCode
 759 --NO:                   || exprSmallEnoughToDup rhs
 760 --                      -- [Andy] added, Jun 95
 761
 762 {- Reinstated AJG Jun 95; This is needed
 763     --example that does not (currently) work
 764     --without this extention
 765
 766     --let f = g x
 767     --in
 768     --  case <exp> of
 769     --     True -> h i f
 770     --     False -> f
 771     --  ==>
 772     --  case <exp> of
 773     --     True -> h i f
 774     --     False -> g x
 775 -}
 776 {- OLD:
 777    Omitted SLPJ Feb 95; should, I claim, be unnecessary
 778         -- is_really_small looks for things like f a b c
 779         -- but making sure there are not *too* many arguments.
 780         -- (This is brought to you by *ANDY* Magic Constants, Inc.)
 781     is_really_small
 782       = case collectArgs new_rhs of
 783           (Var _, _, _, xs) -> length xs < 10
 784           _ -> False
 785 -}
 786 \end{code}
 787
 788 \begin{code}
 789 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
 790
 791 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
 792   | not (isLocallyDefined var)  -- Imported, so look inside the id
 793   = getIdUnfolding var
 794
 795   | otherwise                   -- Locally defined, so look in the envt.
 796                                 -- There'll be nothing inside the Id.
 797   = lookup_unfold_env unfold_env var
 798 \end{code}
 799
 800 We need to remove any @GenForm@ bindings from the UnfoldEnv for
 801 the RHS of an Id which has an INLINE pragma.
 802
 803 \begin{code}
 804 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
 805
 806 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 807   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 808   where
 809     new_unfold_env = null_unfold_env
 810         -- This version is really simple.  INLINEd things are going to
 811         -- be inlined wherever they are used, and then all the
 812         -- UnfoldEnv stuff will take effect.  Meanwhile, there isn't
 813         -- much point in doing anything to the as-yet-un-INLINEd rhs.
 814
 815         -- Andy disagrees! Example:
 816         --      all xs = foldr (&&) True xs
 817         --      any p = all . map p  {-# INLINE any #-}
 818         --
 819         -- Problem: any won't get deforested, and so if it's exported and
 820         -- the importer doesn't use the inlining, (eg passes it as an arg)
 821         -- then we won't get deforestation at all.
 822         --
 823         -- So he'd like not to filter the unfold env at all.  But that's a disaster:
 824         -- Suppose we have:
 825         --
 826         -- let f = \pq -> BIG
 827         -- in
 828         -- let g = \y -> f y y
 829         --     {-# INLINE g #-}
 830         -- in ...g...g...g...g...g...
 831         --
 832         -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 833         -- and thence copied multiple times when g is inlined.
 834 \end{code}
 835
 836 ======================
 837
 838 In @lookForConstructor@ we used (before Apr 94) to have a special case
 839 for nullary constructors:
 840
 841 \begin{verbatim}
 842   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 843         -- let
 844         --        a = leInt#! p q
 845         -- in
 846         -- case a of
 847         --    True  -> ...
 848         --    False -> False
 849         --
 850         -- Here the False in the second case will get replace by "a", hardly
 851         -- a good idea
 852     Nothing
 853 \end{verbatim}
 854
 855 but now we only do constructor re-use in let-bindings the special
 856 case isn't necessary any more.
 857
 858 \begin{code}
 859 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
 860   = lookup_conapp unfold_env con args
 861 \end{code}