ghc/compiler/simplCore/SimplEnv.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   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 --UNUSED: getInEnvs,
  14         replaceInEnvs, nullInEnvs,
  15
  16         nullTyVarEnv,
  17         extendTyEnv, extendTyEnvList,
  18         simplTy, simplTyInId,
  19
  20         extendIdEnvWithAtom, extendIdEnvWithAtomList,
  21         extendIdEnvWithInlining,
  22         extendIdEnvWithClone, extendIdEnvWithClones,
  23         lookupId,
  24
  25         extendUnfoldEnvGivenRhs,
  26 --OLD:  extendUnfoldEnvWithRecInlinings,
  27         extendUnfoldEnvGivenFormDetails,
  28         extendUnfoldEnvGivenConstructor,
  29         lookForConstructor,
  30         lookupUnfolding, filterUnfoldEnvForInlines,
  31
  32         getSwitchChecker, switchIsSet,
  33
  34 --UNUSED: getEnclosingCC,
  35         setEnclosingCC,
  36
  37         mkFormSummary,
  38
  39         -- Types
  40         SwitchChecker(..),
  41         SimplEnv, UnfoldingDetails(..), UnfoldingGuidance(..),
  42         FormSummary(..), EnclosingCcDetails(..),
  43         InIdEnv(..), IdVal(..), InTypeEnv(..),
  44         UnfoldEnv, UnfoldItem, UnfoldConApp,
  45
  46         -- re-exported from BinderInfo
  47         BinderInfo(..),
  48         FunOrArg, DuplicationDanger, InsideSCC, -- sigh
  49
  50         InId(..),  InBinder(..),  InType(..),  InBinding(..),  InUniType(..),
  51         OutId(..), OutBinder(..), OutType(..), OutBinding(..), OutUniType(..),
  52
  53         InExpr(..),  InAtom(..),  InAlts(..),  InDefault(..),  InArg(..),
  54         OutExpr(..), OutAtom(..), OutAlts(..), OutDefault(..), OutArg(..),
  55
  56         -- and to make the interface self-sufficient...
  57         BasicLit, GlobalSwitch, SimplifierSwitch, SwitchResult, CoreAtom,
  58         CoreCaseAlternatives, CoreExpr, Id,
  59         IdEnv(..), UniqFM, Unique,
  60         MagicUnfoldingFun, Maybe, TyVar, TyVarEnv(..), UniType
  61
  62         IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToTy COMMA applyTypeEnvToId)
  63         IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA lookupUFM COMMA lookupIdEnv) -- profiling
  64     ) where
  65
  66 IMPORT_Trace
  67
  68 import AbsUniType       ( applyTypeEnvToTy, getUniDataTyCon, cmpUniType )
  69 import Bag              ( emptyBag, Bag )
  70 import BasicLit         ( isNoRepLit, BasicLit(..), PrimKind ) -- .. for pragmas only
  71 import BinderInfo
  72 import CmdLineOpts      ( switchIsOn, intSwitchSet,
  73                           SimplifierSwitch(..), SwitchResult
  74                         )
  75 import CgCompInfo       ( uNFOLDING_CREATION_THRESHOLD )
  76 import CostCentre
  77 import FiniteMap
  78 import Id               ( getIdUnfolding, eqId, cmpId, applyTypeEnvToId,
  79                           getIdUniType, getIdStrictness, isWorkerId,
  80                           isBottomingId
  81                         )
  82 import IdEnv
  83 import IdInfo
  84 import MagicUFs
  85 import Maybes           ( assocMaybe, maybeToBool, Maybe(..) )
  86 import OccurAnal        ( occurAnalyseExpr )
  87 import PlainCore        -- for the "Out*" types and things
  88 import Pretty           -- debugging only
  89 import SimplUtils       ( simplIdWantsToBeINLINEd )
  90 import TaggedCore       -- for the "In*" types and things
  91 import TyVarEnv
  92 import UniqFM           ( lookupDirectlyUFM, addToUFM_Directly, ufmToList )
  93 import UniqSet
  94 import Util
  95 \end{code}
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsection[Simplify-types]{Type declarations}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsubsection{The @SimplEnv@ type}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110
 111 INVARIANT: we assume {\em no shadowing}.  (ToDo: How can we ASSERT
 112 this? WDP 94/06) This allows us to neglect keeping everything paired
 113 with its static environment.
 114
 115 The environment contains bindings for all
 116         {\em in-scope,}
 117         {\em locally-defined}
 118 things.
 119
 120 For such things, any unfolding is found in the environment, not in the
 121 Id.  Unfoldings in the Id itself are used only for imported things
 122 (otherwise we get trouble because we have to simplify the unfoldings
 123 inside the Ids, etc.).
 124
 125 \begin{code}
 126 data SimplEnv
 127   = SimplEnv
 128         (SwitchChecker SimplifierSwitch)
 129
 130         EnclosingCcDetails -- the enclosing cost-centre (when profiling)
 131
 132         InTypeEnv       -- For cloning types
 133                         -- Domain is all in-scope type variables
 134
 135         InIdEnv         -- IdEnv
 136                         -- Domain is
 137                         --      *all*
 138                         --      *in-scope*,
 139                         --      *locally-defined*
 140                         --      *InIds*
 141                         -- (Could omit the exported top-level guys,
 142                         -- since their names mustn't change; and ditto
 143                         -- the non-exported top-level guys which you
 144                         -- don't want to macro-expand, since their
 145                         -- names need not change.)
 146                         --
 147                         -- Starts off empty
 148
 149         UnfoldEnv       -- Domain is any *OutIds*, including imports
 150                         -- where we know something more than the
 151                         -- interface file tells about their value (see
 152                         -- below)
 153
 154 nullSimplEnv :: SwitchChecker SimplifierSwitch -> SimplEnv
 155
 156 nullSimplEnv sw_chkr
 157   = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
 158
 159 pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
 160   = ppAboves [
 161         ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env,
 162         ppSP, ppStr "** Id Env ** ?????????",
 163 --      ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ],
 164         ppSP, ppStr "** Unfold Env **",
 165         ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ]
 166     ]
 167   where
 168     pp_id_entry (v, idval)
 169       = ppCat [ppr PprDebug v, ppStr "=>",
 170                case idval of
 171                  InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
 172                  ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a]
 173               ]
 174
 175     pp_uf_entry (UnfoldItem v form encl_cc)
 176       = ppCat [ppr PprDebug v, ppStr "=>",
 177                case form of
 178                  NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
 179                  LiteralForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
 180                  OtherLiteralForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") [ppr PprDebug l | l <- ls]]
 181                  ConstructorForm c t a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
 182                  OtherConstructorForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
 183                                                                           [ppr PprDebug c | c <- cs]]
 184                  GeneralForm t w e g -> ppCat [ppStr "UF:",
 185                                                         ppr PprDebug t,
 186                                                         ppr PprDebug w,
 187                                                         ppr PprDebug g, ppr PprDebug e]
 188                  MagicForm s _ -> ppCat [ppStr "Magic:", ppPStr s]
 189                  IWantToBeINLINEd _ -> ppStr "IWantToBeINLINEd"
 190               ]
 191 \end{code}
 192
 193 %************************************************************************
 194 %*                                                                      *
 195 \subsubsection{The @IdVal@ type (for the ``IdEnv'')}
 196 %*                                                                      *
 197 %************************************************************************
 198
 199 The unfoldings for imported things are mostly kept within the Id
 200 itself; nevertheless, they {\em can} get into the @UnfoldEnv@.  For
 201 example, suppose \tr{x} is imported, and we have
 202 \begin{verbatim}
 203         case x of
 204           (p,q) -> <body>
 205 \end{verbatim}
 206 Then within \tr{<body>}, we know that \tr{x} is a pair with components
 207 \tr{p} and \tr{q}.
 208
 209 \begin{code}
 210 type InIdEnv = IdEnv IdVal      -- Maps InIds to their value
 211
 212 data IdVal
 213   = InlineIt InIdEnv InTypeEnv InExpr
 214                 -- No binding of the Id is left;
 215                 -- You *have* to replace any occurences
 216                 -- of the id with this expression.
 217                 -- Rather like a macro, really
 218                 -- NB: the InIdEnv/InTypeEnv is necessary to prevent
 219                 -- name caputure. Consider:
 220                 --      let y = ...
 221                 --          x = ...y...
 222                 --          y = ...
 223                 --      in ...x...
 224                 -- If x gets an InlineIt, we must remember
 225                 -- the correct binding for y.
 226
 227   | ItsAnAtom OutAtom   -- Used either (a) to record the cloned Id
 228                         -- or (b) if the orig defn is a let-binding, and
 229                         -- the RHS of the let simplifies to an atom,
 230                         -- we just bind the variable to that atom, and
 231                         -- elide the let.
 232 \end{code}
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 \subsubsection{The @UnfoldEnv@, @UnfoldingDetails@, and @UnfoldingGuidance@ types}
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 The @UnfoldEnv@ contains information about the value of some of the
 241 in-scope identifiers.  It obeys the following invariant:
 242
 243         If the @UnfoldEnv@ contains information, it is safe to use it!
 244
 245 In particular, if the @UnfoldEnv@ contains details of an unfolding of
 246 an Id, then it's safe to use the unfolding.  If, for example, the Id
 247 is used many times, then its unfolding won't be put in the UnfoldEnv
 248 at all.
 249
 250 The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
 251 because (a)~it's small, and (b)~we need to search its {\em range} as
 252 well as its domain.
 253
 254 \begin{code}
 255 data UnfoldItem -- a glorified triple...
 256   = UnfoldItem  OutId                   -- key: used in lookForConstructor
 257                 UnfoldingDetails        -- for that Id
 258                 EnclosingCcDetails      -- so that if we do an unfolding,
 259                                         -- we can "wrap" it in the CC
 260                                         -- that was in force.
 261
 262 data UnfoldConApp -- yet another glorified triple
 263   = UCA         OutId                   -- same fields as ConstructorForm;
 264                 [UniType]               -- a new type so we can make
 265                 [OutAtom]               -- Ord work on it (instead of on
 266                                         -- UnfoldingDetails).
 267
 268 data UnfoldEnv  -- yup, a glorified triple...
 269   = UFE         (IdEnv UnfoldItem)      -- Maps an OutId => its UnfoldItem
 270                 IdSet                   -- The Ids in the domain of the env
 271                                         -- which have details (GeneralForm True ...)
 272                                         -- i.e., they claim they are duplicatable.
 273                                         -- These are the ones we have to worry
 274                                         -- about when adding new items to the
 275                                         -- unfold env.
 276                 (FiniteMap UnfoldConApp OutId)
 277                                         -- Maps applications of constructors (to
 278                                         -- types & atoms) back to OutIds that are
 279                                         -- bound to them; i.e., this is a reversed
 280                                         -- mapping for (part of) the main IdEnv
 281                                         -- (1st part of UFE)
 282
 283 null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
 284 \end{code}
 285
 286 The @UnfoldEnv@ type.  We expect on the whole that an @UnfoldEnv@ will
 287 be small, because it contains bindings only for those things whose
 288 form or unfolding is known.  Basically it maps @Id@ to their
 289 @UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
 290 need to search it associatively, to look for @Id@s which have a given
 291 constructor form.
 292
 293 We implement it with @IdEnvs@, possibly overkill, but sometimes these
 294 things silently grow quite big....  Here are some local functions used
 295 elsewhere in the module:
 296
 297 \begin{code}
 298 grow_unfold_env   :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
 299 lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
 300 lookup_unfold_env_encl_cc
 301                   :: UnfoldEnv -> OutId -> EnclosingCcDetails
 302
 303 grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
 304
 305 grow_unfold_env (UFE u_env interesting_ids con_apps) id
 306                 uf_details@(GeneralForm True _ _ _) encl_cc
 307     -- Only interested in Ids which have a "dangerous" unfolding; that is
 308     -- one that claims to have a single occurrence.
 309   = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
 310         (interesting_ids `unionUniqSets` singletonUniqSet id)
 311         con_apps
 312
 313 grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
 314   = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
 315         interesting_ids
 316         new_con_apps
 317   where
 318     new_con_apps
 319       = case uf_details of
 320           ConstructorForm con targs vargs
 321             -> case (lookupFM con_apps entry) of
 322                  Just _  -> con_apps -- unchanged; we hang onto what we have
 323                  Nothing -> addToFM con_apps entry id
 324             where
 325               entry = UCA con targs vargs
 326
 327           not_a_constructor -> con_apps -- unchanged
 328
 329 addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
 330   = ASSERT(not (any constructor_form_in_those extra_items))
 331     -- otherwise, we'd need to change con_apps
 332     UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
 333   where
 334     constructor_form_in_those (_, UnfoldItem _ (ConstructorForm _ _ _) _) = True
 335     constructor_form_in_those _ = False
 336
 337 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
 338
 339 get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
 340
 341 foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
 342   = UFE (foldr fun u_env stuff) interesting_ids con_apps
 343
 344 lookup_unfold_env (UFE u_env _ _) id
 345   = case (lookupIdEnv u_env id) of
 346       Nothing                  -> NoUnfoldingDetails
 347       Just (UnfoldItem _ uf _) -> uf
 348
 349 lookup_unfold_env_encl_cc (UFE u_env _ _) id
 350   = case (lookupIdEnv u_env id) of
 351       Nothing                       -> NoEnclosingCcDetails
 352       Just (UnfoldItem _ _ encl_cc) -> encl_cc
 353
 354 lookup_conapp (UFE _ _ con_apps) con ty_args con_args
 355   = lookupFM con_apps (UCA con ty_args con_args)
 356
 357 modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
 358   = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
 359
 360 -- If the current binding claims to be a "unique" one, then
 361 -- we modify it.
 362 modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
 363
 364 modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
 365   = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
 366 \end{code}
 367
 368 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 369 it, so we can use it for a @FiniteMap@ key.
 370 \begin{code}
 371 instance Eq  UnfoldConApp where
 372     a == b = case cmp_app a b of { EQ_ -> True;   _ -> False }
 373     a /= b = case cmp_app a b of { EQ_ -> False;  _ -> True  }
 374
 375 instance Ord UnfoldConApp where
 376     a <= b = case cmp_app a b of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 377     a <  b = case cmp_app a b of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 378     a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 379     a >  b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 380 #ifdef __GLASGOW_HASKELL__
 381     _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 382 #endif
 383
 384 cmp_app (UCA c1 tys1 as1) (UCA c2 tys2 as2)
 385   = case cmpId c1 c2 of
 386       LT_ -> LT_
 387       GT_ -> GT_
 388       _   -> case (cmp_lists (cmpUniType True{-properly-}) tys1 tys2) of
 389                LT_ -> LT_
 390                GT_ -> GT_
 391                _   -> cmp_lists cmp_atom as1 as2
 392   where
 393     cmp_lists cmp_item []     []     = EQ_
 394     cmp_lists cmp_item (x:xs) []     = GT_
 395     cmp_lists cmp_item []     (y:ys) = LT_
 396     cmp_lists cmp_item (x:xs) (y:ys)
 397       = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
 398
 399     cmp_atom (CoVarAtom x) (CoVarAtom y) = x `cmpId` y
 400     cmp_atom (CoVarAtom _) _             = LT_
 401     cmp_atom (CoLitAtom x) (CoLitAtom y)
 402 #ifdef __GLASGOW_HASKELL__
 403       = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
 404 #else
 405       = if x == y then EQ_ elsid if x < y then LT_ else GT_
 406 #endif
 407     cmp_atom (CoLitAtom _) _             = GT_
 408 \end{code}
 409
 410 \begin{code}
 411 data UnfoldingDetails
 412   = NoUnfoldingDetails
 413
 414   | LiteralForm
 415         BasicLit
 416
 417   | OtherLiteralForm
 418         [BasicLit]              -- It is a literal, but definitely not one of these
 419
 420   | ConstructorForm
 421         Id                      -- The constructor
 422         [UniType]               -- Type args
 423         [OutAtom]               -- Value arguments; NB OutAtoms, already cloned
 424
 425   | OtherConstructorForm
 426         [Id]                    -- It definitely isn't one of these constructors
 427                                 -- This captures the situation in the default branch of
 428                                 -- a case:  case x of
 429                                 --              c1 ... -> ...
 430                                 --              c2 ... -> ...
 431                                 --              v -> default-rhs
 432                                 -- Then in default-rhs we know that v isn't c1 or c2.
 433                                 --
 434                                 -- NB.  In the degenerate: case x of {v -> default-rhs}
 435                                 -- x will be bound to
 436                                 --      OtherConstructorForm []
 437                                 -- which captures the idea that x is eval'd but we don't
 438                                 -- know which constructor.
 439
 440
 441   | GeneralForm
 442         Bool                    -- True <=> At most one textual occurrence of the
 443                                 --              binder in its scope, *or*
 444                                 --              if we are happy to duplicate this
 445                                 --              binding.
 446         FormSummary             -- Tells whether the template is a WHNF or bottom
 447         TemplateOutExpr         -- The template
 448         UnfoldingGuidance       -- Tells about the *size* of the template.
 449
 450   | MagicForm
 451         FAST_STRING
 452         MagicUnfoldingFun
 453
 454   {-OLD? Nukable? ("Also turgid" SLPJ)-}
 455   | IWantToBeINLINEd            -- Means this has an INLINE pragma;
 456                                 -- Used for things which have a defn in this module
 457         UnfoldingGuidance       -- Guidance from the pragma; usually UnfoldAlways.
 458
 459 data FormSummary
 460   = WhnfForm            -- Expression is WHNF
 461   | BottomForm          -- Expression is guaranteed to be bottom. We're more gung
 462                         -- ho about inlining such things, because it can't waste work
 463   | OtherForm           -- Anything else
 464
 465 instance Outputable FormSummary where
 466    ppr sty WhnfForm   = ppStr "WHNF"
 467    ppr sty BottomForm = ppStr "Bot"
 468    ppr sty OtherForm  = ppStr "Other"
 469
 470 mkFormSummary :: StrictnessInfo -> CoreExpr bndr Id -> FormSummary
 471 mkFormSummary si expr
 472   | manifestlyWHNF     expr = WhnfForm
 473   | bottomIsGuaranteed si   = BottomForm
 474
 475   -- Chances are that the Id will be decorated with strictness info
 476   -- telling that the RHS is definitely bottom.  This *might* not be the
 477   -- case, if it's been a while since strictness analysis, but leaving out
 478   -- the test for manifestlyBottom makes things a little more efficient.
 479   -- We can always put it back...
 480   -- | manifestlyBottom expr  = BottomForm
 481
 482   | otherwise = OtherForm
 483 \end{code}
 484
 485 \begin{code}
 486 data UnfoldingGuidance
 487   = UnfoldNever                 -- Don't do it!
 488
 489   | UnfoldAlways                -- There is no "original" definition,
 490                                 -- so you'd better unfold.  Or: something
 491                                 -- so cheap to unfold (e.g., 1#) that
 492                                 -- you should do it absolutely always.
 493
 494   | EssentialUnfolding          -- Like UnfoldAlways, but you *must* do
 495                                 -- it absolutely always.
 496                                 -- This is what we use for data constructors
 497                                 -- and PrimOps, because we don't feel like
 498                                 -- generating curried versions "just in case".
 499
 500   | UnfoldIfGoodArgs    Int     -- if "m" type args and "n" value args; and
 501                         Int     -- those val args are manifestly data constructors
 502                         [Bool]  -- the val-arg positions marked True
 503                                 -- (i.e., a simplification will definitely
 504                                 -- be possible).
 505                         Int     -- The "size" of the unfolding; to be elaborated
 506                                 -- later. ToDo
 507
 508   | BadUnfolding                -- This is used by TcPragmas if the *lazy*
 509                                 -- lintUnfolding test fails
 510                                 -- It will never escape from the IdInfo as
 511                                 -- it is caught by getInfo_UF and converted
 512                                 -- to NoUnfoldingDetails
 513 \end{code}
 514
 515 \begin{code}
 516 instance Outputable UnfoldingGuidance where
 517     ppr sty UnfoldNever         = ppStr "_N_"
 518     ppr sty UnfoldAlways        = ppStr "_ALWAYS_"
 519     ppr sty EssentialUnfolding  = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
 520     ppr sty (UnfoldIfGoodArgs t v cs size)
 521       = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
 522                if null cs       -- always print *something*
 523                 then ppChar 'X'
 524                 else ppBesides (map pp_c cs),
 525                ppInt size ]
 526       where
 527         pp_c False = ppChar 'X'
 528         pp_c True  = ppChar 'C'
 529 \end{code}
 530
 531 %************************************************************************
 532 %*                                                                      *
 533 \subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
 534 %*                                                                      *
 535 %************************************************************************
 536
 537 \begin{code}
 538 mkGenForm :: Bool               -- Ok to Dup code down different case branches,
 539                                 -- because of either a flag saying so,
 540                                 -- or alternatively the object is *SMALL*
 541           -> BinderInfo         --
 542           -> FormSummary
 543           -> TemplateOutExpr    -- Template
 544           -> UnfoldingGuidance  -- Tells about the *size* of the template.
 545           -> UnfoldingDetails
 546
 547 mkGenForm safe_to_dup occ_info WhnfForm template guidance
 548   = GeneralForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance
 549
 550 mkGenForm safe_to_dup occ_info form_summary template guidance
 551   | oneSafeOcc safe_to_dup occ_info     -- Non-WHNF with only safe occurrences
 552   = GeneralForm True form_summary template guidance
 553
 554   | otherwise                           -- Not a WHNF, many occurrences
 555   = NoUnfoldingDetails
 556 \end{code}
 557
 558 \begin{code}
 559 modifyUnfoldingDetails
 560         :: Bool         -- OK to dup
 561         -> BinderInfo   -- New occurrence info for the thing
 562         -> UnfoldingDetails
 563         -> UnfoldingDetails
 564
 565 modifyUnfoldingDetails ok_to_dup occ_info
 566         (GeneralForm only_one form_summary template guidance)
 567   | only_one  = mkGenForm ok_to_dup occ_info form_summary template guidance
 568
 569 {- OLD:
 570         | otherwise = NoUnfoldingDetails
 571    I can't see why we zap bindings which don't claim to be unique
 572 -}
 573
 574 modifyUnfoldingDetails ok_to_dup occ_info other = other
 575 \end{code}
 576
 577 %************************************************************************
 578 %*                                                                      *
 579 \subsubsection{The @EnclosingCcDetails@ type}
 580 %*                                                                      *
 581 %************************************************************************
 582
 583 \begin{code}
 584 data EnclosingCcDetails
 585   = NoEnclosingCcDetails
 586   | EnclosingCC     CostCentre
 587 \end{code}
 588
 589 %************************************************************************
 590 %*                                                                      *
 591 \subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
 592 %*                                                                      *
 593 %************************************************************************
 594
 595 \begin{code}
 596 type InId      = Id                     -- Not yet cloned
 597 type InBinder  = (InId, BinderInfo)
 598 type InType    = UniType                        -- Ditto
 599 type InBinding = SimplifiableCoreBinding
 600 type InExpr    = SimplifiableCoreExpr
 601 type InAtom    = SimplifiableCoreAtom   -- same as PlainCoreAtom
 602 type InAlts    = SimplifiableCoreCaseAlternatives
 603 type InDefault = SimplifiableCoreCaseDefault
 604 type InArg     = CoreArg InId
 605 type InUniType = UniType
 606
 607 type OutId      = Id                    -- Cloned
 608 type OutBinder  = Id
 609 type OutType    = UniType               -- Cloned
 610 type OutBinding = PlainCoreBinding
 611 type OutExpr    = PlainCoreExpr
 612 type OutAtom    = PlainCoreAtom
 613 type OutAlts    = PlainCoreCaseAlternatives
 614 type OutDefault = PlainCoreCaseDefault
 615 type OutArg     = CoreArg OutId
 616 type OutUniType = UniType
 617
 618 type TemplateOutExpr = CoreExpr (OutId, BinderInfo) OutId
 619         -- An OutExpr with occurrence info attached
 620         -- This is used as a template in GeneralForms.
 621 \end{code}
 622
 623 \begin{code}
 624 type SwitchChecker switch = switch -> SwitchResult
 625 \end{code}
 626
 627 %************************************************************************
 628 %*                                                                      *
 629 \subsection{@SimplEnv@ handling}
 630 %*                                                                      *
 631 %************************************************************************
 632
 633 %************************************************************************
 634 %*                                                                      *
 635 \subsubsection{Command-line switches}
 636 %*                                                                      *
 637 %************************************************************************
 638
 639 \begin{code}
 640 getSwitchChecker :: SimplEnv -> SwitchChecker SimplifierSwitch
 641 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
 642
 643 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
 644 switchIsSet (SimplEnv chkr _ _ _ _) switch
 645   = switchIsOn chkr switch
 646 \end{code}
 647
 648 %************************************************************************
 649 %*                                                                      *
 650 \subsubsection{The ``enclosing cost-centre''}
 651 %*                                                                      *
 652 %************************************************************************
 653
 654 \begin{code}
 655 -- UNUSED:
 656 --getEnclosingCC :: SimplEnv -> EnclosingCcDetails
 657 --getEnclosingCC (SimplEnv _ encl_cc _ _ _) = encl_cc
 658
 659 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
 660
 661 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
 662   = SimplEnv chkr encl_cc ty_env id_env unfold_env
 663 \end{code}
 664
 665 %************************************************************************
 666 %*                                                                      *
 667 \subsubsection{The @TypeEnv@ part}
 668 %*                                                                      *
 669 %************************************************************************
 670
 671 \begin{code}
 672 type InTypeEnv = TypeEnv        -- Maps InTyVars to OutUniTypes
 673
 674 extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv
 675 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
 676   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 677   where
 678     new_ty_env = addOneToTyVarEnv ty_env tyvar ty
 679
 680 extendTyEnvList :: SimplEnv -> [(TyVar,UniType)] -> SimplEnv
 681 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
 682   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 683   where
 684     new_ty_env = growTyVarEnvList ty_env pairs
 685
 686 simplTy     (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
 687
 688 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
 689 \end{code}
 690
 691 @replaceInEnvs@ is used to install saved type and id envs
 692 when pulling an un-simplified expression out of the environment, which
 693 was saved with its environments.
 694
 695 \begin{code}
 696 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
 697
 698 -- UNUSED:
 699 --getInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv)
 700 --getInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) = (ty_env,id_env)
 701
 702 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
 703 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 704               (new_ty_env, new_id_env)
 705   = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
 706 \end{code}
 707
 708 %************************************************************************
 709 %*                                                                      *
 710 \subsubsection{The ``Id env'' part}
 711 %*                                                                      *
 712 %************************************************************************
 713
 714 \begin{code}
 715 extendIdEnvWithAtom
 716         :: SimplEnv
 717         -> InBinder -> OutAtom
 718         -> SimplEnv
 719
 720 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(CoLitAtom lit)
 721   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 722   where
 723     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 724
 725 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 726             (in_id, occ_info) atom@(CoVarAtom out_id)
 727   = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
 728   where
 729     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 730
 731     new_unfold_env = modify_unfold_env
 732                         unfold_env
 733                         (modifyItem ok_to_dup occ_info)
 734                         out_id
 735                 -- Modify binding for in_id
 736                 -- NO! modify out_id, because its the info on the
 737                 -- atom that interest's us.
 738
 739     ok_to_dup    = switchIsOn chkr SimplOkToDupCode
 740
 741 extendIdEnvWithAtomList
 742         :: SimplEnv
 743         -> [(InBinder, OutAtom)]
 744         -> SimplEnv
 745 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 746
 747 extendIdEnvWithInlining
 748         :: SimplEnv             -- The Env to modify
 749         -> SimplEnv             -- The Env to record in the inlining.  Usually the
 750                                 -- same as the previous one, except in the recursive case
 751         -> InBinder -> InExpr
 752         -> SimplEnv
 753
 754 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env        id_env        unfold_env)
 755                         ~(SimplEnv _   _       inline_ty_env inline_id_env _         )
 756                         (in_id,occ_info)
 757                         expr
 758   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 759   where
 760     new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
 761
 762 extendIdEnvWithClone
 763         :: SimplEnv
 764         -> InBinder     -- Old binder; binderinfo ignored
 765         -> OutId        -- Its new clone, as an Id
 766         -> SimplEnv
 767
 768 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 769         (in_id,_) out_id
 770   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 771   where
 772     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (CoVarAtom out_id))
 773
 774 extendIdEnvWithClones   -- Like extendIdEnvWithClone
 775         :: SimplEnv
 776         -> [InBinder]
 777         -> [OutId]
 778         -> SimplEnv
 779
 780 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 781         in_binders out_ids
 782   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 783   where
 784     new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
 785     in_ids     = [id | (id,_) <- in_binders]
 786     out_vals   = [ItsAnAtom (CoVarAtom out_id) | out_id <- out_ids]
 787
 788 lookupId :: SimplEnv -> Id -> Maybe IdVal
 789
 790 lookupId (SimplEnv _ _ _ id_env _) id
 791 #ifndef DEBUG
 792   = lookupIdEnv id_env id
 793 #else
 794   = case (lookupIdEnv id_env id) of
 795       xxx@(Just _) -> xxx
 796       xxx          -> --false!: ASSERT(not (isLocallyDefined id))
 797                       xxx
 798 #endif
 799 \end{code}
 800
 801 %************************************************************************
 802 %*                                                                      *
 803 \subsubsection{The @UnfoldEnv@}
 804 %*                                                                      *
 805 %************************************************************************
 806
 807 \begin{code}
 808 extendUnfoldEnvGivenFormDetails
 809         :: SimplEnv
 810         -> OutId
 811         -> UnfoldingDetails
 812         -> SimplEnv
 813
 814 extendUnfoldEnvGivenFormDetails
 815         env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 816         id details
 817   = case details of
 818       NoUnfoldingDetails -> env
 819       good_details       -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 820         where
 821           new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
 822
 823 extendUnfoldEnvGivenConstructor -- specialised variant
 824         :: SimplEnv
 825         -> OutId                -- bind this to...
 826         -> Id -> [OutId]        -- "con <tys-to-be-invented> args"
 827         -> SimplEnv
 828
 829 extendUnfoldEnvGivenConstructor env var con args
 830   = let
 831         -- conjure up the types to which the con should be applied
 832         scrut_ty        = getIdUniType var
 833         (_, ty_args, _) = getUniDataTyCon scrut_ty
 834     in
 835     extendUnfoldEnvGivenFormDetails
 836       env var (ConstructorForm con ty_args (map CoVarAtom args))
 837 \end{code}
 838
 839
 840 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 841 of a new binding.  There is a horrid case we have to take care about,
 842 due to Andr\'e Santos:
 843 @
 844     type Array_type b   = Array Int b;
 845     type Descr_type     = (Int,Int);
 846
 847     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 848     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 849
 850     f_iaamain a_xs=
 851         let {
 852             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 853             f_aareorder a_index a_ar=
 854                 let {
 855                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 856                  } in  tabulate f_aareorder' (bounds a_ar);
 857             r_index=tabulate ((+) 1) (1,1);
 858             arr    = listArray (1,1) a_xs;
 859             arg    = f_aareorder r_index arr
 860          } in  elems arg
 861 @
 862 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 863 @
 864         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 865                in tabulate f_aareorder' (bounds arr)
 866 @
 867 Note that r_index is not inlined, because it was bound to a_index which
 868 occurs inside a lambda.
 869
 870 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 871 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 872 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 873 will get inlined inside the lambda.  AARGH.
 874
 875 Solution: when we occurrence-analyse the new RHS we have to go back
 876 and modify the info recorded in the UnfoldEnv for the free vars
 877 of the RHS.  In the example we'd go back and record that r_index is now used
 878 inside a lambda.
 879
 880 \begin{code}
 881 extendUnfoldEnvGivenRhs
 882         :: SimplEnv
 883         -> InBinder
 884         -> OutId        -- Note: *must* be an "out" Id (post-cloning)
 885         -> OutExpr      -- Its rhs (*simplified*)
 886         -> SimplEnv
 887
 888 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 889                         binder@(_,occ_info) out_id rhs
 890   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 891   where
 892         -- Occurrence-analyse the RHS
 893     (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
 894
 895     interesting_fvs = get_interesting_ids unfold_env
 896
 897         -- Compute unfolding details
 898     details = case rhs of
 899                 CoVar v                    -> panic "CoVars already dealt with"
 900                 CoLit lit | isNoRepLit lit -> LiteralForm lit
 901                           | otherwise      -> panic "non-noRep CoLits already dealt with"
 902
 903                 CoCon con tys args         -> ConstructorForm con tys args
 904
 905                 other -> mkGenForm ok_to_dup occ_info
 906                                    (mkFormSummary (getIdStrictness out_id) rhs)
 907                                    template guidance
 908
 909         -- Compute resulting unfold env
 910     new_unfold_env = case details of
 911                         NoUnfoldingDetails      -> unfold_env
 912                         GeneralForm _ _ _ _     -> unfold_env2{-test: unfold_env1 -}
 913                         other                   -> unfold_env1
 914
 915         -- Add unfolding to unfold env
 916     unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
 917
 918         -- Modify unfoldings of free vars of rhs, based on their
 919         -- occurrence info in the rhs [see notes above]
 920     unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
 921
 922     modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
 923     modify (u, occ_info) env
 924       = case (lookupDirectlyUFM env u) of
 925           Nothing -> env -- ToDo: can this happen?
 926           Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
 927
 928         -- Compute unfolding guidance
 929     guidance = if simplIdWantsToBeINLINEd out_id env
 930                then UnfoldAlways
 931                else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
 932
 933     bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
 934                       Nothing -> uNFOLDING_CREATION_THRESHOLD
 935                       Just xx -> xx
 936
 937     ok_to_dup     = switchIsOn chkr SimplOkToDupCode
 938                         || exprSmallEnoughToDup rhs
 939                         -- [Andy] added, Jun 95
 940
 941 {- Reinstated AJG Jun 95; This is needed
 942     --example that does not (currently) work
 943     --without this extention
 944
 945     --let f = g x
 946     --in
 947     --  case <exp> of
 948     --     True -> h i f
 949     --     False -> f
 950     --  ==>
 951     --  case <exp> of
 952     --     True -> h i f
 953     --     False -> g x
 954 -}
 955 {- OLD:
 956    Omitted SLPJ Feb 95; should, I claim, be unnecessary
 957         -- is_really_small looks for things like f a b c
 958         -- but making sure there are not *too* many arguments.
 959         -- (This is brought to you by *ANDY* Magic Constants, Inc.)
 960     is_really_small
 961       = case collectArgs new_rhs of
 962           (CoVar _, xs) -> length xs < 10
 963           _ -> False
 964 -}
 965
 966
 967 {- UNUSED:
 968 extendUnfoldEnvWithRecInlinings :: SimplEnv -> [OutId] -> [InExpr] -> SimplEnv
 969
 970 extendUnfoldEnvWithRecInlinings env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 971                                 new_ids old_rhss
 972   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 973   where
 974     extra_unfold_items
 975       = [ (new_id, UnfoldItem new_id
 976                         (GeneralForm True
 977                                      (mkFormSummary (getIdStrictness new_id) old_rhs)
 978                                      old_rhs UnfoldAlways)
 979                         encl_cc)
 980         | (new_id, old_rhs) <- new_ids `zipEqual` old_rhss,
 981           simplIdWantsToBeINLINEd new_id env
 982         ]
 983
 984     new_unfold_env = addto_unfold_env unfold_env extra_unfold_items
 985 -}
 986 \end{code}
 987
 988 \begin{code}
 989 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
 990
 991 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
 992   | not (isLocallyDefined var)  -- Imported, so look inside the id
 993   = getIdUnfolding var
 994
 995   | otherwise                   -- Locally defined, so look in the envt.
 996                                 -- There'll be nothing inside the Id.
 997   = lookup_unfold_env unfold_env var
 998 \end{code}
 999
1000 We need to remove any @GeneralForm@ bindings from the UnfoldEnv for
1001 the RHS of an Id which has an INLINE pragma.
1002
1003 \begin{code}
1004 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
1005
1006 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
1007   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
1008   where
1009     new_unfold_env = null_unfold_env
1010         -- This version is really simple.  INLINEd things are going to
1011         -- be inlined wherever they are used, and then all the
1012         -- UnfoldEnv stuff will take effect.  Meanwhile, there isn't
1013         -- much point in doing anything to the as-yet-un-INLINEd rhs.
1014
1015         -- Andy disagrees! Example:
1016         --      all xs = foldr (&&) True xs
1017         --      any p = all . map p  {-# INLINE any #-}
1018         --
1019         -- Problem: any won't get deforested, and so if it's exported and
1020         -- the importer doesn't use the inlining, (eg passes it as an arg)
1021         -- then we won't get deforestation at all.
1022         --
1023         -- So he'd like not to filter the unfold env at all.  But that's a disaster:
1024         -- Suppose we have:
1025         --
1026         -- let f = \pq -> BIG
1027         -- in
1028         -- let g = \y -> f y y
1029         --     {-# INLINE g #-}
1030         -- in ...g...g...g...g...g...
1031         --
1032         -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
1033         -- and thence copied multiple times when g is inlined.
1034 \end{code}
1035
1036 ======================
1037
1038 In @lookForConstructor@ we used (before Apr 94) to have a special case
1039 for nullary constructors:
1040
1041 \begin{verbatim}
1042   =     -- Don't re-use nullary constructors; it's a waste.  Consider
1043         -- let
1044         --        a = leInt#! p q
1045         -- in
1046         -- case a of
1047         --    True  -> ...
1048         --    False -> False
1049         --
1050         -- Here the False in the second case will get replace by "a", hardly
1051         -- a good idea
1052     Nothing
1053 \end{verbatim}
1054
1055 but now we only do constructor re-use in let-bindings the special
1056 case isn't necessary any more.
1057
1058 \begin{code}
1059 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con ty_args con_args
1060   = lookup_conapp unfold_env con ty_args con_args
1061 \end{code}