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