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 \end{code}
 509
 510 \begin{code}
 511 instance Outputable UnfoldingGuidance where
 512     ppr sty UnfoldNever         = ppStr "_N_"
 513     ppr sty UnfoldAlways        = ppStr "_ALWAYS_"
 514     ppr sty EssentialUnfolding  = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
 515     ppr sty (UnfoldIfGoodArgs t v cs size)
 516       = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
 517                if null cs       -- always print *something*
 518                 then ppChar 'X'
 519                 else ppBesides (map pp_c cs),
 520                ppInt size ]
 521       where
 522         pp_c False = ppChar 'X'
 523         pp_c True  = ppChar 'C'
 524 \end{code}
 525
 526 %************************************************************************
 527 %*                                                                      *
 528 \subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
 529 %*                                                                      *
 530 %************************************************************************
 531
 532 \begin{code}
 533 mkGenForm :: Bool               -- Ok to Dup code down different case branches,
 534                                 -- because of either a flag saying so,
 535                                 -- or alternatively the object is *SMALL*
 536           -> BinderInfo         --
 537           -> FormSummary
 538           -> TemplateOutExpr    -- Template
 539           -> UnfoldingGuidance  -- Tells about the *size* of the template.
 540           -> UnfoldingDetails
 541
 542 mkGenForm safe_to_dup occ_info WhnfForm template guidance
 543   = GeneralForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance
 544
 545 mkGenForm safe_to_dup occ_info form_summary template guidance
 546   | oneSafeOcc safe_to_dup occ_info     -- Non-WHNF with only safe occurrences
 547   = GeneralForm True form_summary template guidance
 548
 549   | otherwise                           -- Not a WHNF, many occurrences
 550   = NoUnfoldingDetails
 551 \end{code}
 552
 553 \begin{code}
 554 modifyUnfoldingDetails
 555         :: Bool         -- OK to dup
 556         -> BinderInfo   -- New occurrence info for the thing
 557         -> UnfoldingDetails
 558         -> UnfoldingDetails
 559
 560 modifyUnfoldingDetails ok_to_dup occ_info
 561         (GeneralForm only_one form_summary template guidance)
 562   | only_one  = mkGenForm ok_to_dup occ_info form_summary template guidance
 563
 564 {- OLD:
 565         | otherwise = NoUnfoldingDetails
 566    I can't see why we zap bindings which don't claim to be unique
 567 -}
 568
 569 modifyUnfoldingDetails ok_to_dup occ_info other = other
 570 \end{code}
 571
 572 %************************************************************************
 573 %*                                                                      *
 574 \subsubsection{The @EnclosingCcDetails@ type}
 575 %*                                                                      *
 576 %************************************************************************
 577
 578 \begin{code}
 579 data EnclosingCcDetails
 580   = NoEnclosingCcDetails
 581   | EnclosingCC     CostCentre
 582 \end{code}
 583
 584 %************************************************************************
 585 %*                                                                      *
 586 \subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
 587 %*                                                                      *
 588 %************************************************************************
 589
 590 \begin{code}
 591 type InId      = Id                     -- Not yet cloned
 592 type InBinder  = (InId, BinderInfo)
 593 type InType    = UniType                        -- Ditto
 594 type InBinding = SimplifiableCoreBinding
 595 type InExpr    = SimplifiableCoreExpr
 596 type InAtom    = SimplifiableCoreAtom   -- same as PlainCoreAtom
 597 type InAlts    = SimplifiableCoreCaseAlternatives
 598 type InDefault = SimplifiableCoreCaseDefault
 599 type InArg     = CoreArg InId
 600 type InUniType = UniType
 601
 602 type OutId      = Id                    -- Cloned
 603 type OutBinder  = Id
 604 type OutType    = UniType               -- Cloned
 605 type OutBinding = PlainCoreBinding
 606 type OutExpr    = PlainCoreExpr
 607 type OutAtom    = PlainCoreAtom
 608 type OutAlts    = PlainCoreCaseAlternatives
 609 type OutDefault = PlainCoreCaseDefault
 610 type OutArg     = CoreArg OutId
 611 type OutUniType = UniType
 612
 613 type TemplateOutExpr = CoreExpr (OutId, BinderInfo) OutId
 614         -- An OutExpr with occurrence info attached
 615         -- This is used as a template in GeneralForms.
 616 \end{code}
 617
 618 \begin{code}
 619 type SwitchChecker switch = switch -> SwitchResult
 620 \end{code}
 621
 622 %************************************************************************
 623 %*                                                                      *
 624 \subsection{@SimplEnv@ handling}
 625 %*                                                                      *
 626 %************************************************************************
 627
 628 %************************************************************************
 629 %*                                                                      *
 630 \subsubsection{Command-line switches}
 631 %*                                                                      *
 632 %************************************************************************
 633
 634 \begin{code}
 635 getSwitchChecker :: SimplEnv -> SwitchChecker SimplifierSwitch
 636 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
 637
 638 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
 639 switchIsSet (SimplEnv chkr _ _ _ _) switch
 640   = switchIsOn chkr switch
 641 \end{code}
 642
 643 %************************************************************************
 644 %*                                                                      *
 645 \subsubsection{The ``enclosing cost-centre''}
 646 %*                                                                      *
 647 %************************************************************************
 648
 649 \begin{code}
 650 -- UNUSED:
 651 --getEnclosingCC :: SimplEnv -> EnclosingCcDetails
 652 --getEnclosingCC (SimplEnv _ encl_cc _ _ _) = encl_cc
 653
 654 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
 655
 656 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
 657   = SimplEnv chkr encl_cc ty_env id_env unfold_env
 658 \end{code}
 659
 660 %************************************************************************
 661 %*                                                                      *
 662 \subsubsection{The @TypeEnv@ part}
 663 %*                                                                      *
 664 %************************************************************************
 665
 666 \begin{code}
 667 type InTypeEnv = TypeEnv        -- Maps InTyVars to OutUniTypes
 668
 669 extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv
 670 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
 671   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 672   where
 673     new_ty_env = addOneToTyVarEnv ty_env tyvar ty
 674
 675 extendTyEnvList :: SimplEnv -> [(TyVar,UniType)] -> SimplEnv
 676 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
 677   = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
 678   where
 679     new_ty_env = growTyVarEnvList ty_env pairs
 680
 681 simplTy     (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
 682
 683 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
 684 \end{code}
 685
 686 @replaceInEnvs@ is used to install saved type and id envs
 687 when pulling an un-simplified expression out of the environment, which
 688 was saved with its environments.
 689
 690 \begin{code}
 691 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
 692
 693 -- UNUSED:
 694 --getInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv)
 695 --getInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) = (ty_env,id_env)
 696
 697 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
 698 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 699               (new_ty_env, new_id_env)
 700   = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
 701 \end{code}
 702
 703 %************************************************************************
 704 %*                                                                      *
 705 \subsubsection{The ``Id env'' part}
 706 %*                                                                      *
 707 %************************************************************************
 708
 709 \begin{code}
 710 extendIdEnvWithAtom
 711         :: SimplEnv
 712         -> InBinder -> OutAtom
 713         -> SimplEnv
 714
 715 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(CoLitAtom lit)
 716   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 717   where
 718     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 719
 720 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 721             (in_id, occ_info) atom@(CoVarAtom out_id)
 722   = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
 723   where
 724     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
 725
 726     new_unfold_env = modify_unfold_env
 727                         unfold_env
 728                         (modifyItem ok_to_dup occ_info)
 729                         out_id
 730                 -- Modify binding for in_id
 731                 -- NO! modify out_id, because its the info on the
 732                 -- atom that interest's us.
 733
 734     ok_to_dup    = switchIsOn chkr SimplOkToDupCode
 735
 736 extendIdEnvWithAtomList
 737         :: SimplEnv
 738         -> [(InBinder, OutAtom)]
 739         -> SimplEnv
 740 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 741
 742 extendIdEnvWithInlining
 743         :: SimplEnv             -- The Env to modify
 744         -> SimplEnv             -- The Env to record in the inlining.  Usually the
 745                                 -- same as the previous one, except in the recursive case
 746         -> InBinder -> InExpr
 747         -> SimplEnv
 748
 749 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env        id_env        unfold_env)
 750                         ~(SimplEnv _   _       inline_ty_env inline_id_env _         )
 751                         (in_id,occ_info)
 752                         expr
 753   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 754   where
 755     new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
 756
 757 extendIdEnvWithClone
 758         :: SimplEnv
 759         -> InBinder     -- Old binder; binderinfo ignored
 760         -> OutId        -- Its new clone, as an Id
 761         -> SimplEnv
 762
 763 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 764         (in_id,_) out_id
 765   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 766   where
 767     new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (CoVarAtom out_id))
 768
 769 extendIdEnvWithClones   -- Like extendIdEnvWithClone
 770         :: SimplEnv
 771         -> [InBinder]
 772         -> [OutId]
 773         -> SimplEnv
 774
 775 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 776         in_binders out_ids
 777   = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
 778   where
 779     new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
 780     in_ids     = [id | (id,_) <- in_binders]
 781     out_vals   = [ItsAnAtom (CoVarAtom out_id) | out_id <- out_ids]
 782
 783 lookupId :: SimplEnv -> Id -> Maybe IdVal
 784
 785 lookupId (SimplEnv _ _ _ id_env _) id
 786 #ifndef DEBUG
 787   = lookupIdEnv id_env id
 788 #else
 789   = case (lookupIdEnv id_env id) of
 790       xxx@(Just _) -> xxx
 791       xxx          -> --false!: ASSERT(not (isLocallyDefined id))
 792                       xxx
 793 #endif
 794 \end{code}
 795
 796 %************************************************************************
 797 %*                                                                      *
 798 \subsubsection{The @UnfoldEnv@}
 799 %*                                                                      *
 800 %************************************************************************
 801
 802 \begin{code}
 803 extendUnfoldEnvGivenFormDetails
 804         :: SimplEnv
 805         -> OutId
 806         -> UnfoldingDetails
 807         -> SimplEnv
 808
 809 extendUnfoldEnvGivenFormDetails
 810         env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 811         id details
 812   = case details of
 813       NoUnfoldingDetails -> env
 814       good_details       -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 815         where
 816           new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
 817
 818 extendUnfoldEnvGivenConstructor -- specialised variant
 819         :: SimplEnv
 820         -> OutId                -- bind this to...
 821         -> Id -> [OutId]        -- "con <tys-to-be-invented> args"
 822         -> SimplEnv
 823
 824 extendUnfoldEnvGivenConstructor env var con args
 825   = let
 826         -- conjure up the types to which the con should be applied
 827         scrut_ty        = getIdUniType var
 828         (_, ty_args, _) = getUniDataTyCon scrut_ty
 829     in
 830     extendUnfoldEnvGivenFormDetails
 831       env var (ConstructorForm con ty_args (map CoVarAtom args))
 832 \end{code}
 833
 834
 835 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 836 of a new binding.  There is a horrid case we have to take care about,
 837 due to Andr\'e Santos:
 838 @
 839     type Array_type b   = Array Int b;
 840     type Descr_type     = (Int,Int);
 841
 842     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 843     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 844
 845     f_iaamain a_xs=
 846         let {
 847             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 848             f_aareorder a_index a_ar=
 849                 let {
 850                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 851                  } in  tabulate f_aareorder' (bounds a_ar);
 852             r_index=tabulate ((+) 1) (1,1);
 853             arr    = listArray (1,1) a_xs;
 854             arg    = f_aareorder r_index arr
 855          } in  elems arg
 856 @
 857 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 858 @
 859         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 860                in tabulate f_aareorder' (bounds arr)
 861 @
 862 Note that r_index is not inlined, because it was bound to a_index which
 863 occurs inside a lambda.
 864
 865 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 866 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 867 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 868 will get inlined inside the lambda.  AARGH.
 869
 870 Solution: when we occurrence-analyse the new RHS we have to go back
 871 and modify the info recorded in the UnfoldEnv for the free vars
 872 of the RHS.  In the example we'd go back and record that r_index is now used
 873 inside a lambda.
 874
 875 \begin{code}
 876 extendUnfoldEnvGivenRhs
 877         :: SimplEnv
 878         -> InBinder
 879         -> OutId        -- Note: *must* be an "out" Id (post-cloning)
 880         -> OutExpr      -- Its rhs (*simplified*)
 881         -> SimplEnv
 882
 883 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 884                         binder@(_,occ_info) out_id rhs
 885   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 886   where
 887         -- Occurrence-analyse the RHS
 888     (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
 889
 890     interesting_fvs = get_interesting_ids unfold_env
 891
 892         -- Compute unfolding details
 893     details = case rhs of
 894                 CoVar v                    -> panic "CoVars already dealt with"
 895                 CoLit lit | isNoRepLit lit -> LiteralForm lit
 896                           | otherwise      -> panic "non-noRep CoLits already dealt with"
 897
 898                 CoCon con tys args         -> ConstructorForm con tys args
 899
 900                 other -> mkGenForm ok_to_dup occ_info
 901                                    (mkFormSummary (getIdStrictness out_id) rhs)
 902                                    template guidance
 903
 904         -- Compute resulting unfold env
 905     new_unfold_env = case details of
 906                         NoUnfoldingDetails      -> unfold_env
 907                         GeneralForm _ _ _ _     -> unfold_env2{-test: unfold_env1 -}
 908                         other                   -> unfold_env1
 909
 910         -- Add unfolding to unfold env
 911     unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
 912
 913         -- Modify unfoldings of free vars of rhs, based on their
 914         -- occurrence info in the rhs [see notes above]
 915     unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
 916
 917     modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
 918     modify (u, occ_info) env
 919       = case (lookupDirectlyUFM env u) of
 920           Nothing -> env -- ToDo: can this happen?
 921           Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
 922
 923         -- Compute unfolding guidance
 924     guidance = if simplIdWantsToBeINLINEd out_id env
 925                then UnfoldAlways
 926                else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
 927
 928     bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
 929                       Nothing -> uNFOLDING_CREATION_THRESHOLD
 930                       Just xx -> xx
 931
 932     ok_to_dup     = switchIsOn chkr SimplOkToDupCode
 933                         || exprSmallEnoughToDup rhs
 934                         -- [Andy] added, Jun 95
 935
 936 {- Reinstated AJG Jun 95; This is needed
 937     --example that does not (currently) work
 938     --without this extention
 939
 940     --let f = g x
 941     --in
 942     --  case <exp> of
 943     --     True -> h i f
 944     --     False -> f
 945     --  ==>
 946     --  case <exp> of
 947     --     True -> h i f
 948     --     False -> g x
 949 -}
 950 {- OLD:
 951    Omitted SLPJ Feb 95; should, I claim, be unnecessary
 952         -- is_really_small looks for things like f a b c
 953         -- but making sure there are not *too* many arguments.
 954         -- (This is brought to you by *ANDY* Magic Constants, Inc.)
 955     is_really_small
 956       = case collectArgs new_rhs of
 957           (CoVar _, xs) -> length xs < 10
 958           _ -> False
 959 -}
 960
 961
 962 {- UNUSED:
 963 extendUnfoldEnvWithRecInlinings :: SimplEnv -> [OutId] -> [InExpr] -> SimplEnv
 964
 965 extendUnfoldEnvWithRecInlinings env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
 966                                 new_ids old_rhss
 967   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
 968   where
 969     extra_unfold_items
 970       = [ (new_id, UnfoldItem new_id
 971                         (GeneralForm True
 972                                      (mkFormSummary (getIdStrictness new_id) old_rhs)
 973                                      old_rhs UnfoldAlways)
 974                         encl_cc)
 975         | (new_id, old_rhs) <- new_ids `zipEqual` old_rhss,
 976           simplIdWantsToBeINLINEd new_id env
 977         ]
 978
 979     new_unfold_env = addto_unfold_env unfold_env extra_unfold_items
 980 -}
 981 \end{code}
 982
 983 \begin{code}
 984 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
 985
 986 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
 987   | not (isLocallyDefined var)  -- Imported, so look inside the id
 988   = getIdUnfolding var
 989
 990   | otherwise                   -- Locally defined, so look in the envt.
 991                                 -- There'll be nothing inside the Id.
 992   = lookup_unfold_env unfold_env var
 993 \end{code}
 994
 995 We need to remove any @GeneralForm@ bindings from the UnfoldEnv for
 996 the RHS of an Id which has an INLINE pragma.
 997
 998 \begin{code}
 999 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
1000
1001 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
1002   = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
1003   where
1004     new_unfold_env = null_unfold_env
1005         -- This version is really simple.  INLINEd things are going to
1006         -- be inlined wherever they are used, and then all the
1007         -- UnfoldEnv stuff will take effect.  Meanwhile, there isn't
1008         -- much point in doing anything to the as-yet-un-INLINEd rhs.
1009
1010         -- Andy disagrees! Example:
1011         --      all xs = foldr (&&) True xs
1012         --      any p = all . map p  {-# INLINE any #-}
1013         --
1014         -- Problem: any won't get deforested, and so if it's exported and
1015         -- the importer doesn't use the inlining, (eg passes it as an arg)
1016         -- then we won't get deforestation at all.
1017         --
1018         -- So he'd like not to filter the unfold env at all.  But that's a disaster:
1019         -- Suppose we have:
1020         --
1021         -- let f = \pq -> BIG
1022         -- in
1023         -- let g = \y -> f y y
1024         --     {-# INLINE g #-}
1025         -- in ...g...g...g...g...g...
1026         --
1027         -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
1028         -- and thence copied multiple times when g is inlined.
1029 \end{code}
1030
1031 ======================
1032
1033 In @lookForConstructor@ we used (before Apr 94) to have a special case
1034 for nullary constructors:
1035
1036 \begin{verbatim}
1037   =     -- Don't re-use nullary constructors; it's a waste.  Consider
1038         -- let
1039         --        a = leInt#! p q
1040         -- in
1041         -- case a of
1042         --    True  -> ...
1043         --    False -> False
1044         --
1045         -- Here the False in the second case will get replace by "a", hardly
1046         -- a good idea
1047     Nothing
1048 \end{verbatim}
1049
1050 but now we only do constructor re-use in let-bindings the special
1051 case isn't necessary any more.
1052
1053 \begin{code}
1054 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con ty_args con_args
1055   = lookup_conapp unfold_env con ty_args con_args
1056 \end{code}