ghc/compiler/simplCore/SimplCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[SimplCore]{Driver for simplifying @Core@ programs}
   5
   6 \begin{code}
   7 module SimplCore ( core2core ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..),
  12                           SwitchResult, switchIsOn,
  13                           opt_D_dump_occur_anal,
  14                           opt_D_dump_simpl_iterations,
  15                           opt_D_simplifier_stats,
  16                           opt_D_dump_simpl,
  17                           opt_D_verbose_core2core,
  18                           opt_D_dump_occur_anal
  19                         )
  20 import CoreLint         ( beginPass, endPass )
  21 import CoreSyn
  22 import PprCore          ( pprCoreBindings )
  23 import OccurAnal        ( occurAnalyseBinds )
  24 import CoreUtils        ( exprIsTrivial, coreExprType )
  25 import Simplify         ( simplBind )
  26 import SimplUtils       ( etaCoreExpr, findDefault )
  27 import SimplMonad
  28 import CoreUnfold
  29 import Const            ( Con(..), Literal(..), literalType, mkMachInt )
  30 import ErrUtils         ( dumpIfSet )
  31 import FloatIn          ( floatInwards )
  32 import FloatOut         ( floatOutwards )
  33 import Id               ( Id, mkSysLocal, mkUserId,
  34                           setIdVisibility, setIdUnfolding,
  35                           getIdSpecialisation, setIdSpecialisation,
  36                           getInlinePragma, setInlinePragma,
  37                           idType, setIdType
  38                         )
  39 import IdInfo           ( InlinePragInfo(..) )
  40 import VarEnv
  41 import VarSet
  42 import Name             ( isExported, mkSysLocalName,
  43                           Module, NamedThing(..), OccName(..)
  44                         )
  45 import TyCon            ( TyCon, isDataTyCon )
  46 import PrimOp           ( PrimOp(..) )
  47 import PrelInfo         ( unpackCStringId, unpackCString2Id,
  48                           integerZeroId, integerPlusOneId,
  49                           integerPlusTwoId, integerMinusOneId,
  50                           int2IntegerId, addr2IntegerId
  51                         )
  52 import Type             ( Type, splitAlgTyConApp_maybe,
  53                           isUnLiftedType, mkTyVarTy, Type )
  54 import TysWiredIn       ( isIntegerTy )
  55 import LiberateCase     ( liberateCase )
  56 import PprType          ( nmbrType )
  57 import SAT              ( doStaticArgs )
  58 import Specialise       ( specProgram)
  59 import SpecEnv          ( specEnvToList, specEnvFromList )
  60 import StrictAnal       ( saWwTopBinds )
  61 import Var              ( TyVar, setTyVarName )
  62 import Unique           ( Unique, Uniquable(..),
  63                           ratioTyConKey, mkUnique, incrUnique, initTidyUniques
  64                         )
  65 import UniqSupply       ( UniqSupply, splitUniqSupply )
  66 import Constants        ( tARGET_MIN_INT, tARGET_MAX_INT )
  67 import Bag
  68 import Maybes
  69 import IO               ( hPutStr, stderr )
  70 import Outputable
  71 \end{code}
  72
  73 \begin{code}
  74 core2core :: [CoreToDo]         -- Spec of what core-to-core passes to do
  75           -> FAST_STRING        -- Module name (profiling only)
  76           -> UniqSupply         -- A name supply
  77           -> [CoreBind]         -- Input
  78           -> IO [CoreBind]      -- Result
  79
  80 core2core core_todos module_name us binds
  81   = do
  82         -- Do the main business
  83         processed_binds <- doCorePasses us binds core_todos
  84
  85         -- Do the final tidy-up
  86         final_binds <- tidyCorePgm module_name processed_binds
  87
  88         -- Return results
  89         return final_binds
  90
  91 doCorePasses us binds []
  92   = return binds
  93
  94 doCorePasses us binds (to_do : to_dos)
  95   = do
  96         let (us1, us2) =  splitUniqSupply us
  97         binds1         <- doCorePass us1 binds to_do
  98         doCorePasses us2 binds1 to_dos
  99
 100 doCorePass us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify"       simplifyPgm sw_chkr us binds
 101 doCorePass us binds CoreLiberateCase         = _scc_ "LiberateCase"   liberateCase binds
 102 doCorePass us binds CoreDoFloatInwards       = _scc_ "FloatInwards"   floatInwards binds
 103 doCorePass us binds CoreDoFullLaziness       = _scc_ "CoreFloating"   floatOutwards us binds
 104 doCorePass us binds CoreDoStaticArgs         = _scc_ "CoreStaticArgs" doStaticArgs us binds
 105 doCorePass us binds CoreDoStrictness         = _scc_ "CoreStranal"    saWwTopBinds us binds
 106 doCorePass us binds CoreDoSpecialising       = _scc_ "Specialise"     specProgram us binds
 107 \end{code}
 108
 109
 110 %************************************************************************
 111 %*                                                                      *
 112 \subsection{The driver for the simplifier}
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 \begin{code}
 117 simplifyPgm :: (SimplifierSwitch -> SwitchResult)
 118             -> UniqSupply
 119             -> [CoreBind]               -- Input
 120             -> IO [CoreBind]            -- New bindings
 121
 122 simplifyPgm sw_chkr us binds
 123   = do {
 124         beginPass "Simplify";
 125
 126         (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds;
 127
 128         dumpIfSet opt_D_simplifier_stats "Simplifier statistics"
 129                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 130                          text "",
 131                          pprSimplCount counts]);
 132
 133         endPass "Simplify"
 134                 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
 135                 binds'
 136     }
 137   where
 138     max_iterations      = getSimplIntSwitch sw_chkr MaxSimplifierIterations
 139     simpl_switch_is_on  = switchIsOn sw_chkr
 140
 141     core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
 142                          | otherwise               = empty
 143
 144     iteration us iteration_no counts binds
 145       = do {
 146                 -- Occurrence analysis
 147            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds };
 148            dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
 149                      (pprCoreBindings tagged_binds);
 150
 151                 -- Simplify
 152            let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds);
 153                  all_counts        = counts `plusSimplCount` counts'
 154                } ;
 155
 156                 -- Stop if nothing happened; don't dump output
 157            if isZeroSimplCount counts' then
 158                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
 159            else do {
 160
 161                 -- Dump the result of this iteration
 162            dumpIfSet opt_D_dump_simpl_iterations
 163                      ("Simplifier iteration " ++ show iteration_no
 164                       ++ " out of " ++ show max_iterations)
 165                      (vcat[pprSimplCount counts',
 166                            text "",
 167                            core_iter_dump binds']) ;
 168
 169                 -- Stop if we've run out of iterations
 170            if iteration_no == max_iterations then
 171                 do {
 172                     if  max_iterations > 1 then
 173                             hPutStr stderr ("NOTE: Simplifier still going after " ++
 174                                     show max_iterations ++
 175                                     " iterations; bailing out.\n")
 176                     else return ();
 177
 178                     return ("Simplifier baled out", iteration_no, all_counts, binds')
 179                 }
 180
 181                 -- Else loop
 182            else iteration us2 (iteration_no + 1) all_counts binds'
 183         }  }
 184       where
 185           (us1, us2) = splitUniqSupply us
 186
 187
 188 simplTopBinds []              = returnSmpl []
 189 simplTopBinds (bind1 : binds) = (simplBind bind1        $
 190                                  simplTopBinds binds)   `thenSmpl` \ (binds1', binds') ->
 191                                 returnSmpl (binds1' ++ binds')
 192 \end{code}
 193
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 Several tasks are done by @tidyCorePgm@
 202
 203 ----------------
 204         [March 98] Indirections are now elimianted by the occurrence analyser
 205         -- 1.  Eliminate indirections.  The point here is to transform
 206         --      x_local = E
 207         --      x_exported = x_local
 208         --    ==>
 209         --      x_exported = E
 210
 211 2.  Make certain top-level bindings into Globals. The point is that
 212     Global things get externally-visible labels at code generation
 213     time
 214
 215 3.  Make the representation of NoRep literals explicit, and
 216     float their bindings to the top level.  We only do the floating
 217     part for NoRep lits inside a lambda (else no gain).  We need to
 218     take care with      let x = "foo" in e
 219     that we don't end up with a silly binding
 220                         let x = y in e
 221     with a floated "foo".  What a bore.
 222
 223 4.  Convert
 224         case x of {...; x' -> ...x'...}
 225     ==>
 226         case x of {...; _  -> ...x... }
 227     See notes in SimplCase.lhs, near simplDefault for the reasoning here.
 228
 229 5.  *Mangle* cases involving par# in the discriminant.  The unfolding
 230     for par in PrelConc.lhs include case expressions with integer
 231     results solely to fool the strictness analyzer, the simplifier,
 232     and anyone else who might want to fool with the evaluation order.
 233     At this point in the compiler our evaluation order is safe.
 234     Therefore, we convert expressions of the form:
 235
 236         case par# e of
 237           0# -> rhs
 238           _  -> parError#
 239     ==>
 240         case par# e of
 241           _ -> rhs
 242
 243     fork# isn't handled like this - it's an explicit IO operation now.
 244     The reason is that fork# returns a ThreadId#, which gets in the
 245     way of the above scheme.  And anyway, IO is the only guaranteed
 246     way to enforce ordering  --SDM.
 247
 248 6.  Mangle cases involving seq# in the discriminant.  Up to this
 249     point, seq# will appear like this:
 250
 251           case seq# e of
 252                 0# -> seqError#
 253                 _  -> ...
 254
 255     where the 0# branch is purely to bamboozle the strictness analyser
 256     (see case 5 above).  This code comes from an unfolding for 'seq'
 257     in Prelude.hs.  We translate this into
 258
 259           case e of
 260                 _ -> ...
 261
 262     Now that the evaluation order is safe.  The code generator knows
 263     how to push a seq frame on the stack if 'e' is of function type,
 264     or is polymorphic.
 265
 266
 267 7. Do eta reduction for lambda abstractions appearing in:
 268         - the RHS of case alternatives
 269         - the body of a let
 270
 271    These will otherwise turn into local bindings during Core->STG;
 272    better to nuke them if possible.  (In general the simplifier does
 273    eta expansion not eta reduction, up to this point.)
 274
 275 9. Give all binders a nice print-name.  Their uniques aren't changed;
 276    rather we give them lexically unique occ-names, so that we can
 277    safely print the OccNae only in the interface file.  [Bad idea to
 278    change the uniques, because the code generator makes global labels
 279    from the uniques for local thunks etc.]
 280
 281
 282 Special case
 283 ~~~~~~~~~~~~
 284
 285 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
 286 things, and we need local Ids for non-floated stuff):
 287
 288   Don't float stuff out of a binder that's marked as a bottoming Id.
 289   Reason: it doesn't do any good, and creates more CAFs that increase
 290   the size of SRTs.
 291
 292 eg.
 293
 294         f = error "string"
 295
 296 is translated to
 297
 298         f' = unpackCString# "string"
 299         f = error f'
 300
 301 hence f' and f become CAFs.  Instead, the special case for
 302 tidyTopBinding below makes sure this comes out as
 303
 304         f = let f' = unpackCString# "string" in error f'
 305
 306 and we can safely ignore f as a CAF, since it can only ever be entered once.
 307
 308
 309 \begin{code}
 310 tidyCorePgm :: Module -> [CoreBind] -> IO [CoreBind]
 311
 312 tidyCorePgm mod binds_in
 313   = do
 314         beginPass "Tidy Core"
 315
 316         let binds_out = bagToList (initTM mod (tidyTopBindings binds_in))
 317
 318         endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
 319 \end{code}
 320
 321 Top level bindings
 322 ~~~~~~~~~~~~~~~~~~
 323 \begin{code}
 324 tidyTopBindings [] = returnTM emptyBag
 325 tidyTopBindings (b:bs)
 326   = tidyTopBinding  b           $
 327     tidyTopBindings bs
 328
 329 tidyTopBinding :: CoreBind
 330                -> TopTidyM (Bag CoreBind)
 331                -> TopTidyM (Bag CoreBind)
 332
 333 tidyTopBinding (NonRec bndr rhs) thing_inside
 334   = initNestedTM (tidyCoreExpr rhs)             `thenTM` \ (rhs',floats) ->
 335     tidyTopBinder bndr                          $ \ bndr' ->
 336     thing_inside                                `thenTM` \ binds ->
 337     let
 338         this_bind {- | isBottomingId bndr
 339                         = unitBag (NonRec bndr' (foldrBag Let rhs' floats))
 340                   | otherwise  -}
 341                         = floats `snocBag` NonRec bndr' rhs'
 342     in
 343     returnTM (this_bind `unionBags` binds)
 344
 345 tidyTopBinding (Rec pairs) thing_inside
 346   = tidyTopBinders binders                      $ \ binders' ->
 347     initNestedTM (mapTM tidyCoreExpr rhss)      `thenTM` \ (rhss', floats) ->
 348     thing_inside                                `thenTM` \ binds_inside ->
 349     returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
 350   where
 351     (binders, rhss) = unzip pairs
 352 \end{code}
 353
 354 \begin{code}
 355 tidyTopBinder :: Id -> (Id -> TopTidyM (Bag CoreBind)) -> TopTidyM (Bag CoreBind)
 356 tidyTopBinder id thing_inside
 357   = mungeTopBndr id                             $ \ id' ->
 358     let
 359         spec_items = specEnvToList (getIdSpecialisation id')
 360     in
 361     if null spec_items then
 362
 363         -- Common case, no specialisations to tidy
 364         thing_inside id'
 365     else
 366
 367         -- Oh well, tidy those specialisations
 368     initNestedTM (mapTM tidySpecItem spec_items)        `thenTM` \ (spec_items', floats) ->
 369     let
 370         id'' = setIdSpecialisation id' (specEnvFromList spec_items')
 371     in
 372     extendEnvTM id (Var id'')           $
 373     thing_inside id''                   `thenTM` \ binds ->
 374     returnTM (floats `unionBags` binds)
 375
 376 tidyTopBinders []     k = k []
 377 tidyTopBinders (b:bs) k = tidyTopBinder b       $ \ b' ->
 378                           tidyTopBinders bs     $ \ bs' ->
 379                           k (b' : bs')
 380
 381 tidySpecItem (tyvars, tys, rhs)
 382   = newBndrs tyvars             $ \ tyvars' ->
 383     mapTM tidyTy tys            `thenTM` \ tys' ->
 384     tidyCoreExpr rhs            `thenTM` \ rhs' ->
 385     returnTM (tyvars', tys', rhs')
 386 \end{code}
 387
 388 Expressions
 389 ~~~~~~~~~~~
 390 \begin{code}
 391 tidyCoreExpr (Var v) = lookupId v
 392
 393 tidyCoreExpr (Type ty)
 394   = tidyTy ty   `thenTM` \ ty' ->
 395     returnTM (Type ty')
 396
 397 tidyCoreExpr (App fun arg)
 398   = tidyCoreExpr fun    `thenTM` \ fun' ->
 399     tidyCoreExpr arg    `thenTM` \ arg' ->
 400     returnTM (App fun' arg')
 401
 402 tidyCoreExpr (Con (Literal lit) args)
 403   = ASSERT( null args )
 404     litToRep lit        `thenTM` \ (lit_ty, lit_expr) ->
 405     getInsideLambda     `thenTM` \ in_lam ->
 406     if in_lam && not (exprIsTrivial lit_expr) then
 407         -- It must have been a no-rep literal with a
 408         -- non-trivial representation; and we're inside a lambda;
 409         -- so float it to the top
 410         addTopFloat lit_ty lit_expr     `thenTM` \ v ->
 411         returnTM (Var v)
 412     else
 413         returnTM lit_expr
 414
 415 tidyCoreExpr (Con con args)
 416   = mapTM tidyCoreExpr args     `thenTM` \ args' ->
 417     returnTM (Con con args')
 418
 419 tidyCoreExpr (Lam bndr body)
 420   = newBndr bndr                $ \ bndr' ->
 421     insideLambda bndr           $
 422     tidyCoreExpr body           `thenTM` \ body' ->
 423     returnTM (Lam bndr' body')
 424
 425 tidyCoreExpr (Let (NonRec bndr rhs) body)
 426   = tidyCoreExpr rhs            `thenTM` \ rhs' ->
 427     tidyBindNonRec bndr rhs' body
 428
 429 tidyCoreExpr (Let (Rec pairs) body)
 430   = newBndrs bndrs              $ \ bndrs' ->
 431     mapTM tidyCoreExpr rhss     `thenTM` \ rhss' ->
 432     tidyCoreExprEta body        `thenTM` \ body' ->
 433     returnTM (Let (Rec (bndrs' `zip` rhss')) body')
 434   where
 435     (bndrs, rhss) = unzip pairs
 436
 437 tidyCoreExpr (Note (Coerce to_ty from_ty) body)
 438   = tidyCoreExprEta body        `thenTM` \ body' ->
 439     tidyTy to_ty                `thenTM` \ to_ty' ->
 440     tidyTy from_ty              `thenTM` \ from_ty' ->
 441     returnTM (Note (Coerce to_ty' from_ty') body')
 442
 443 tidyCoreExpr (Note note body)
 444   = tidyCoreExprEta body        `thenTM` \ body' ->
 445     returnTM (Note note body')
 446
 447 -- seq#: see notes above.
 448 tidyCoreExpr (Case scrut@(Con (PrimOp SeqOp) [Type _, e]) bndr alts)
 449   = tidyCoreExpr e                      `thenTM` \ e' ->
 450     newBndr bndr                        $ \ bndr' ->
 451     let new_bndr = setIdType bndr' (coreExprType e') in
 452     tidyCoreExprEta default_rhs         `thenTM` \ rhs' ->
 453     returnTM (Case e' new_bndr [(DEFAULT,[],rhs')])
 454   where
 455     (other_alts, maybe_default)  = findDefault alts
 456     Just default_rhs             = maybe_default
 457
 458 -- par#: see notes above.
 459 tidyCoreExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
 460   | funnyParallelOp op && maybeToBool maybe_default
 461   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 462     newBndr bndr                        $ \ bndr' ->
 463     tidyCoreExprEta default_rhs         `thenTM` \ rhs' ->
 464     returnTM (Case scrut' bndr' [(DEFAULT,[],rhs')])
 465   where
 466     (other_alts, maybe_default)  = findDefault alts
 467     Just default_rhs             = maybe_default
 468
 469 tidyCoreExpr (Case scrut case_bndr alts)
 470   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 471     newBndr case_bndr                   $ \ case_bndr' ->
 472     mapTM tidy_alt alts                 `thenTM` \ alts' ->
 473     returnTM (Case scrut' case_bndr' alts')
 474   where
 475     tidy_alt (con,bndrs,rhs) = newBndrs bndrs           $ \ bndrs' ->
 476                                tidyCoreExprEta rhs      `thenTM` \ rhs' ->
 477                                returnTM (con, bndrs', rhs')
 478
 479 tidyCoreExprEta e = tidyCoreExpr e      `thenTM` \ e' ->
 480                     returnTM (etaCoreExpr e')
 481
 482 tidyBindNonRec bndr val' body
 483   | exprIsTrivial val'
 484   = extendEnvTM bndr val' (tidyCoreExpr body)
 485
 486   | otherwise
 487   = newBndr bndr        $ \ bndr' ->
 488     tidyCoreExpr body   `thenTM` \ body' ->
 489     returnTM (Let (NonRec bndr' val') body')
 490 \end{code}
 491
 492
 493 %************************************************************************
 494 %*                                                                      *
 495 \subsection[coreToStg-lits]{Converting literals}
 496 %*                                                                      *
 497 %************************************************************************
 498
 499 Literals: the NoRep kind need to be de-no-rep'd.
 500 We always replace them with a simple variable, and float a suitable
 501 binding out to the top level.
 502
 503 \begin{code}
 504
 505 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
 506
 507 litToRep (NoRepStr s ty)
 508   = returnTM (ty, rhs)
 509   where
 510     rhs = if (any is_NUL (_UNPK_ s))
 511
 512           then   -- Must cater for NULs in literal string
 513                 mkApps (Var unpackCString2Id)
 514                        [mkLit (MachStr s),
 515                         mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
 516
 517           else  -- No NULs in the string
 518                 App (Var unpackCStringId) (mkLit (MachStr s))
 519
 520     is_NUL c = c == '\0'
 521 \end{code}
 522
 523 If an Integer is small enough (Haskell implementations must support
 524 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 525 otherwise, wrap with @litString2Integer@.
 526
 527 \begin{code}
 528 litToRep (NoRepInteger i integer_ty)
 529   = returnTM (integer_ty, rhs)
 530   where
 531     rhs | i == 0    = Var integerZeroId         -- Extremely convenient to look out for
 532         | i == 1    = Var integerPlusOneId      -- a few very common Integer literals!
 533         | i == 2    = Var integerPlusTwoId
 534         | i == (-1) = Var integerMinusOneId
 535
 536         | i > tARGET_MIN_INT &&         -- Small enough, so start from an Int
 537           i < tARGET_MAX_INT
 538         = App (Var int2IntegerId) (Con (Literal (mkMachInt i)) [])
 539
 540         | otherwise                     -- Big, so start from a string
 541         = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
 542
 543
 544 litToRep (NoRepRational r rational_ty)
 545   = tidyCoreExpr (mkLit (NoRepInteger (numerator   r) integer_ty))      `thenTM` \ num_arg ->
 546     tidyCoreExpr (mkLit (NoRepInteger (denominator r) integer_ty))      `thenTM` \ denom_arg ->
 547     returnTM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
 548   where
 549     (ratio_data_con, integer_ty)
 550       = case (splitAlgTyConApp_maybe rational_ty) of
 551           Just (tycon, [i_ty], [con])
 552             -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
 553                (con, i_ty)
 554
 555           _ -> (panic "ratio_data_con", panic "integer_ty")
 556
 557 litToRep other_lit = returnTM (literalType other_lit, mkLit other_lit)
 558 \end{code}
 559
 560 \begin{code}
 561 funnyParallelOp ParOp  = True
 562 funnyParallelOp _      = False
 563 \end{code}
 564
 565
 566 %************************************************************************
 567 %*                                                                      *
 568 \subsection{The monad}
 569 %*                                                                      *
 570 %************************************************************************
 571
 572 \begin{code}
 573 type TidyM a state =  Module
 574                       -> Bool           -- True <=> inside a *value* lambda
 575                       -> (TyVarEnv Type, IdEnv CoreExpr, IdOrTyVarSet)
 576                                 -- Substitution and in-scope binders
 577                       -> state
 578                       -> (a, state)
 579
 580 type TopTidyM  a = TidyM a Unique
 581 type NestTidyM a = TidyM a (Unique,                     -- Global names
 582                             Unique,                     -- Local names
 583                             Bag CoreBind)               -- Floats
 584
 585
 586 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
 587
 588 initTM :: Module -> TopTidyM a -> a
 589 initTM mod m
 590   = case m mod False {- not inside lambda -} empty_env initialTopTidyUnique of
 591         (result, _) -> result
 592   where
 593     empty_env = (emptyVarEnv, emptyVarEnv, emptyVarSet)
 594
 595 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBind)
 596 initNestedTM m mod in_lam env global_us
 597   = case m mod in_lam env (global_us, initialNestedTidyUnique, emptyBag) of
 598         (result, (global_us', _, floats)) -> ((result, floats), global_us')
 599
 600 returnTM v mod in_lam env usf = (v, usf)
 601 thenTM m k mod in_lam env usf = case m mod in_lam env usf of
 602                                   (r, usf') -> k r mod in_lam env usf'
 603
 604 mapTM f []     = returnTM []
 605 mapTM f (x:xs) = f x            `thenTM` \ r ->
 606                  mapTM f xs     `thenTM` \ rs ->
 607                  returnTM (r:rs)
 608
 609 insideLambda :: CoreBndr -> NestTidyM a -> NestTidyM a
 610 insideLambda bndr m mod in_lam env usf | isId bndr = m mod True   env usf
 611                                        | otherwise = m mod in_lam env usf
 612
 613 getInsideLambda :: NestTidyM Bool
 614 getInsideLambda mod in_lam env usf = (in_lam, usf)
 615 \end{code}
 616
 617 Need to extend the environment when we munge a binder, so that
 618 occurrences of the binder will print the correct way (e.g. as a global
 619 not a local).
 620
 621 In cases where we don't clone the binder (because it's an exported
 622 id), we still zap the unfolding and inline pragma info so that
 623 unnecessary gumph isn't carried into the code generator.  This fixes a
 624 nasty space leak.
 625
 626 \begin{code}
 627 mungeTopBndr id thing_inside mod in_lam env@(ty_env, val_env, in_scope) us
 628   = thing_inside id' mod in_lam (ty_env, val_env', in_scope') us'
 629   where
 630   (id', us') | isExported id = (zapSomeIdInfo id, us)
 631              | otherwise = (zapSomeIdInfo (setIdVisibility (Just mod) us id),
 632                             incrUnique us)
 633   val_env'  = extendVarEnv val_env id (Var id')
 634   in_scope' = extendVarSet in_scope id'
 635
 636 zapSomeIdInfo id = id `setIdUnfolding` noUnfolding `setInlinePragma` new_ip
 637   where new_ip = case getInlinePragma id of
 638                         ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo
 639                         something_else          -> something_else
 640
 641 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
 642 addTopFloat lit_ty lit_rhs mod in_lam env (gus, lus, floats)
 643   = let
 644         gus'      = incrUnique gus
 645         lit_local = mkSysLocal gus lit_ty
 646         lit_id    = setIdVisibility (Just mod) gus lit_local
 647     in
 648     (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
 649
 650 lookupId :: Id -> TidyM CoreExpr state
 651 lookupId v mod in_lam (_, val_env, _) usf
 652   = case lookupVarEnv val_env v of
 653         Nothing -> (Var v, usf)
 654         Just e  -> (e,     usf)
 655
 656 extendEnvTM :: Id -> CoreExpr -> (TidyM a state) -> TidyM a state
 657 extendEnvTM v e m mod in_lam (ty_env, val_env, in_scope) usf
 658   = m mod in_lam (ty_env, extendVarEnv val_env v e, in_scope) usf
 659 \end{code}
 660
 661
 662 Making new local binders
 663 ~~~~~~~~~~~~~~~~~~~~~~~~
 664 \begin{code}
 665 newBndr tyvar thing_inside mod in_lam (ty_env, val_env, in_scope) (gus, local_uniq, floats)
 666   | isTyVar tyvar
 667   = let
 668         local_uniq' = incrUnique local_uniq
 669         tyvar'      = setTyVarName tyvar (mkSysLocalName local_uniq)
 670         ty_env'     = extendVarEnv ty_env tyvar (mkTyVarTy tyvar')
 671         in_scope'   = extendVarSet in_scope tyvar'
 672     in
 673     thing_inside tyvar' mod in_lam (ty_env', val_env, in_scope') (gus, local_uniq', floats)
 674
 675 newBndr id thing_inside mod in_lam (ty_env, val_env, in_scope) (gus, local_uniq, floats)
 676   | isId id
 677   = let
 678         -- Give the Id a fresh print-name, *and* rename its type
 679         local_uniq'  = incrUnique local_uniq
 680         name'        = mkSysLocalName local_uniq
 681         ty'          = nmbrType ty_env local_uniq' (idType id)
 682
 683         id'          = mkUserId name' ty'
 684                         -- NB: This throws away the IdInfo of the Id, which we
 685                         -- no longer need.  That means we don't need to
 686                         -- run over it with env, nor renumber it.
 687
 688         val_env'     = extendVarEnv val_env id (Var id')
 689         in_scope'    = extendVarSet in_scope id'
 690     in
 691     thing_inside id' mod in_lam (ty_env, val_env', in_scope') (gus, local_uniq', floats)
 692
 693 newBndrs [] thing_inside
 694   = thing_inside []
 695 newBndrs (bndr:bndrs) thing_inside
 696   = newBndr bndr        $ \ bndr' ->
 697     newBndrs bndrs      $ \ bndrs' ->
 698     thing_inside (bndr' : bndrs')
 699 \end{code}
 700
 701 Re-numbering types
 702 ~~~~~~~~~~~~~~~~~~
 703 \begin{code}
 704 tidyTy ty mod in_lam (ty_env, val_env, in_scope) usf@(_, local_uniq, _)
 705   = (nmbrType ty_env local_uniq ty, usf)
 706         -- We can use local_uniq as a base for renaming forall'd variables
 707         -- in the type; we don't need to know how many are consumed.
 708 \end{code}
 709
 710 -- Get rid of this function when we move to the new code generator.
 711
 712 \begin{code}
 713 typeOkForCase :: Type -> Bool
 714 typeOkForCase ty
 715   | isUnLiftedType ty   -- Primitive case
 716   = True
 717
 718   | otherwise
 719   = case (splitAlgTyConApp_maybe ty) of
 720       Just (tycon, ty_args, [])                                     -> False
 721       Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
 722       other                                                         -> False
 723       -- Null data cons => type is abstract, which code gen can't
 724       -- currently handle.  (ToDo: when return-in-heap is universal we
 725       -- don't need to worry about this.)
 726 \end{code}