ghc/compiler/simplCore/SimplCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 AnalFBWW         ( analFBWW )
  12 import Bag              ( isEmptyBag, foldBag )
  13 import BinderInfo       ( BinderInfo{-instance Outputable-} )
  14 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
  15                           opt_D_show_passes,
  16                           opt_D_simplifier_stats,
  17                           opt_D_dump_simpl,
  18                           opt_D_verbose_core2core,
  19                           opt_DoCoreLinting,
  20                           opt_FoldrBuildOn,
  21                           opt_ReportWhyUnfoldingsDisallowed,
  22                           opt_ShowImportSpecs,
  23                           opt_LiberateCaseThreshold
  24                         )
  25 import CoreLint         ( lintCoreBindings )
  26 import CoreSyn
  27 import CoreUtils        ( coreExprType )
  28 import SimplUtils       ( etaCoreExpr, typeOkForCase )
  29 import CoreUnfold
  30 import Literal          ( Literal(..), literalType, mkMachInt )
  31 import ErrUtils         ( ghcExit, dumpIfSet, doIfSet )
  32 import FiniteMap        ( FiniteMap, emptyFM )
  33 import FloatIn          ( floatInwards )
  34 import FloatOut         ( floatOutwards )
  35 import FoldrBuildWW     ( mkFoldrBuildWW )
  36 import MkId             ( mkSysLocal, mkUserId )
  37 import Id               ( setIdVisibility,
  38                           getIdDemandInfo, idType,
  39                           nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
  40                           lookupIdEnv, IdEnv,
  41                           Id
  42                         )
  43 import IdInfo           ( willBeDemanded, DemandInfo )
  44 import Name             ( isExported, isLocallyDefined,
  45                           isLocalName, uniqToOccName,
  46                           setNameVisibility,
  47                           Module, NamedThing(..), OccName(..)
  48                         )
  49 import TyCon            ( TyCon )
  50 import PrimOp           ( PrimOp(..) )
  51 import PrelVals         ( unpackCStringId, unpackCString2Id,
  52                           integerZeroId, integerPlusOneId,
  53                           integerPlusTwoId, integerMinusOneId
  54                         )
  55 import Type             ( splitAlgTyConApp_maybe, isUnpointedType, Type )
  56 import TysWiredIn       ( stringTy, isIntegerTy )
  57 import LiberateCase     ( liberateCase )
  58 import MagicUFs         ( MagicUnfoldingFun )
  59 import PprCore
  60 import PprType          ( nmbrType )
  61 import SAT              ( doStaticArgs )
  62 import SimplMonad       ( zeroSimplCount, showSimplCount, SimplCount )
  63 import SimplPgm         ( simplifyPgm )
  64 import Specialise
  65 import StrictAnal       ( saWwTopBinds )
  66 import TyVar            ( TyVar, nameTyVar )
  67 import Unique           ( Unique{-instance Eq-}, Uniquable(..),
  68                           integerTyConKey, ratioTyConKey,
  69                           mkUnique, incrUnique,
  70                           initTidyUniques
  71                         )
  72 import UniqSupply       ( UniqSupply, mkSplitUniqSupply,
  73                           splitUniqSupply, getUnique
  74                         )
  75 import UniqFM           ( UniqFM, lookupUFM, addToUFM )
  76 import Util             ( mapAccumL )
  77 import SrcLoc           ( noSrcLoc )
  78 import Constants        ( tARGET_MIN_INT, tARGET_MAX_INT )
  79 import Bag
  80 import Maybes
  81 import IO               ( hPutStr, stderr )
  82 import Outputable
  83 \end{code}
  84
  85 \begin{code}
  86 core2core :: [CoreToDo]                 -- spec of what core-to-core passes to do
  87           -> FAST_STRING                -- module name (profiling only)
  88           -> UniqSupply         -- a name supply
  89           -> [TyCon]                    -- local data tycons and tycon specialisations
  90           -> [CoreBinding]              -- input...
  91           -> IO [CoreBinding]           -- results: program
  92
  93 core2core core_todos module_name us local_tycons binds
  94   =     -- Do the main business
  95      foldl_mn do_core_pass
  96                 (binds, us, zeroSimplCount)
  97                 core_todos
  98                 >>= \ (processed_binds, us', simpl_stats) ->
  99
 100         -- Do the final tidy-up
 101      let
 102         final_binds = tidyCorePgm module_name processed_binds
 103      in
 104      lintCoreBindings "TidyCorePgm" True final_binds    >>
 105
 106
 107         -- Dump output
 108      dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core)
 109         "Core transformations"
 110         (pprCoreBindings final_binds)                   >>
 111
 112         -- Report statistics
 113      doIfSet opt_D_simplifier_stats
 114          (hPutStr stderr ("\nSimplifier Stats:\n")      >>
 115           hPutStr stderr (showSimplCount simpl_stats)   >>
 116           hPutStr stderr "\n")                                  >>
 117
 118         -- Return results
 119     return final_binds
 120   where
 121     --------------
 122     do_core_pass info@(binds, us, simpl_stats) to_do =
 123      case (splitUniqSupply us) of
 124       (us1,us2) ->
 125         case to_do of
 126           CoreDoSimplify simpl_sw_chkr
 127             -> _scc_ "CoreSimplify"
 128                begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 129                                          then " (foldr/build)" else "") >>
 130                case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
 131                  (p, it_cnt, simpl_stats2)
 132                    -> end_pass us2 p simpl_stats2
 133                                ("Simplify (" ++ show it_cnt ++ ")"
 134                                  ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 135                                     then " foldr/build" else "")
 136
 137           CoreDoFoldrBuildWorkerWrapper
 138             -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
 139                begin_pass "FBWW" >>
 140                case (mkFoldrBuildWW us1 binds) of { binds2 ->
 141                end_pass us2 binds2 simpl_stats "FBWW" }
 142
 143           CoreDoFoldrBuildWWAnal
 144             -> _scc_ "CoreDoFoldrBuildWWAnal"
 145                begin_pass "AnalFBWW" >>
 146                case (analFBWW binds) of { binds2 ->
 147                end_pass us2 binds2 simpl_stats "AnalFBWW" }
 148
 149           CoreLiberateCase
 150             -> _scc_ "LiberateCase"
 151                begin_pass "LiberateCase" >>
 152                case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
 153                end_pass us2 binds2 simpl_stats "LiberateCase" }
 154
 155           CoreDoFloatInwards
 156             -> _scc_ "FloatInwards"
 157                begin_pass "FloatIn" >>
 158                case (floatInwards binds) of { binds2 ->
 159                end_pass us2 binds2 simpl_stats "FloatIn" }
 160
 161           CoreDoFullLaziness
 162             -> _scc_ "CoreFloating"
 163                begin_pass "FloatOut" >>
 164                case (floatOutwards us1 binds) of { binds2 ->
 165                end_pass us2 binds2 simpl_stats "FloatOut" }
 166
 167           CoreDoStaticArgs
 168             -> _scc_ "CoreStaticArgs"
 169                begin_pass "StaticArgs" >>
 170                case (doStaticArgs binds us1) of { binds2 ->
 171                end_pass us2 binds2 simpl_stats "StaticArgs" }
 172                 -- Binds really should be dependency-analysed for static-
 173                 -- arg transformation... Not to worry, they probably are.
 174                 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
 175
 176           CoreDoStrictness
 177             -> _scc_ "CoreStranal"
 178                begin_pass "StrAnal" >>
 179                case (saWwTopBinds us1 binds) of { binds2 ->
 180                end_pass us2 binds2 simpl_stats "StrAnal" }
 181
 182           CoreDoSpecialising
 183             -> _scc_ "Specialise"
 184                begin_pass "Specialise" >>
 185                case (specProgram us1 binds) of { p ->
 186                end_pass us2 p simpl_stats "Specialise"
 187                }
 188
 189           CoreDoPrintCore       -- print result of last pass
 190             -> dumpIfSet (not opt_D_verbose_core2core) "Print Core"
 191                   (pprCoreBindings binds)       >>
 192                return (binds, us1, simpl_stats)
 193
 194     -------------------------------------------------
 195
 196     begin_pass what
 197       = if opt_D_show_passes
 198         then hPutStr stderr ("*** Core2Core: "++what++"\n")
 199         else return ()
 200
 201     end_pass us2 binds2
 202              simpl_stats2 what
 203       = -- Report verbosely, if required
 204         dumpIfSet opt_D_verbose_core2core what
 205             (pprCoreBindings binds2)            >>
 206
 207         lintCoreBindings what True {- spec_done -} binds2               >>
 208                 -- The spec_done flag tells the linter to
 209                 -- complain about unboxed let-bindings
 210                 -- But we're not specialising unboxed types any more,
 211                 -- so its irrelevant.
 212
 213         return
 214           (binds2,      -- processed binds, possibly run thru CoreLint
 215            us2,         -- UniqSupply for the next guy
 216            simpl_stats2 -- accumulated simplifier stats
 217           )
 218
 219
 220 -- here so it can be inlined...
 221 foldl_mn f z []     = return z
 222 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 223                       foldl_mn f zz xs
 224 \end{code}
 225
 226
 227
 228 %************************************************************************
 229 %*                                                                      *
 230 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
 231 %*                                                                      *
 232 %************************************************************************
 233
 234 Several tasks are done by @tidyCorePgm@
 235
 236 ----------------
 237         [March 98] Indirections are now elimianted by the occurrence analyser
 238         -- 1.  Eliminate indirections.  The point here is to transform
 239         --      x_local = E
 240         --      x_exported = x_local
 241         --    ==>
 242         --      x_exported = E
 243
 244 2.  Make certain top-level bindings into Globals. The point is that
 245     Global things get externally-visible labels at code generation
 246     time
 247
 248 3.  Make the representation of NoRep literals explicit, and
 249     float their bindings to the top level
 250
 251 4.  Convert
 252         case x of {...; x' -> ...x'...}
 253     ==>
 254         case x of {...; _  -> ...x... }
 255     See notes in SimplCase.lhs, near simplDefault for the reasoning here.
 256
 257 5.  *Mangle* cases involving fork# and par# in the discriminant.  The
 258     original templates for these primops (see @PrelVals.lhs@) constructed
 259     case expressions with boolean results solely to fool the strictness
 260     analyzer, the simplifier, and anyone else who might want to fool with
 261     the evaluation order.  At this point in the compiler our evaluation
 262     order is safe.  Therefore, we convert expressions of the form:
 263
 264         case par# e of
 265           True -> rhs
 266           False -> parError#
 267     ==>
 268         case par# e of
 269           _ -> rhs
 270
 271 6.      Eliminate polymorphic case expressions.  We can't generate code for them yet.
 272
 273 7.      Do eta reduction for lambda abstractions appearing in:
 274                 - the RHS of case alternatives
 275                 - the body of a let
 276         These will otherwise turn into local bindings during Core->STG; better to
 277         nuke them if possible.   (In general the simplifier does eta expansion not
 278         eta reduction, up to this point.)
 279
 280 8.      Do let-to-case.  See notes in Simplify.lhs for why we defer let-to-case
 281         for multi-constructor types.
 282
 283 9.      Give all binders a nice print-name.  Their uniques aren't changed; rather we give
 284         them lexically unique occ-names, so that we can safely print the OccNae only
 285         in the interface file.  [Bad idea to change the uniques, because the code
 286         generator makes global labels from the uniques for local thunks etc.]
 287
 288
 289
 290
 291 \begin{code}
 292 tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
 293
 294 tidyCorePgm mod binds_in
 295   = initTM mod nullIdEnv $
 296     tidyTopBindings binds_in    `thenTM` \ binds ->
 297     returnTM (bagToList binds)
 298 \end{code}
 299
 300 Top level bindings
 301 ~~~~~~~~~~~~~~~~~~
 302 \begin{code}
 303 tidyTopBindings [] = returnTM emptyBag
 304 tidyTopBindings (b:bs)
 305   = tidyTopBinding  b           $
 306     tidyTopBindings bs
 307
 308 tidyTopBinding :: CoreBinding
 309                -> TopTidyM (Bag CoreBinding)
 310                -> TopTidyM (Bag CoreBinding)
 311
 312 tidyTopBinding (NonRec bndr rhs) thing_inside
 313   = initNestedTM (tidyCoreExpr rhs)             `thenTM` \ (rhs',floats) ->
 314     mungeTopBinder bndr                         $ \ bndr' ->
 315     thing_inside                                `thenTM` \ binds ->
 316     returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
 317
 318 tidyTopBinding (Rec pairs) thing_inside
 319   = mungeTopBinders binders                     $ \ binders' ->
 320     initNestedTM (mapTM tidyCoreExpr rhss)      `thenTM` \ (rhss', floats) ->
 321     thing_inside                                `thenTM` \ binds_inside ->
 322     returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
 323   where
 324     (binders, rhss) = unzip pairs
 325 \end{code}
 326
 327
 328
 329 Expressions
 330 ~~~~~~~~~~~
 331 \begin{code}
 332 tidyCoreExpr (Var v) = lookupId v       `thenTM` \ v' ->
 333                        returnTM (Var v')
 334
 335 tidyCoreExpr (Lit lit)
 336   = litToRep lit        `thenTM` \ (_, lit_expr) ->
 337     returnTM lit_expr
 338
 339 tidyCoreExpr (App fun arg)
 340   = tidyCoreExpr fun    `thenTM` \ fun' ->
 341     tidyCoreArg arg     `thenTM` \ arg' ->
 342     returnTM (App fun' arg')
 343
 344 tidyCoreExpr (Con con args)
 345   = mapTM tidyCoreArg args      `thenTM` \ args' ->
 346     returnTM (Con con args')
 347
 348 tidyCoreExpr (Prim prim args)
 349   = tidyPrimOp prim             `thenTM` \ prim' ->
 350     mapTM tidyCoreArg args      `thenTM` \ args' ->
 351     returnTM (Prim prim' args')
 352
 353 tidyCoreExpr (Lam (ValBinder v) body)
 354   = newId v                     $ \ v' ->
 355     tidyCoreExpr body           `thenTM` \ body' ->
 356     returnTM (Lam (ValBinder v') body')
 357
 358 tidyCoreExpr (Lam (TyBinder tv) body)
 359   = newTyVar tv                 $ \ tv' ->
 360     tidyCoreExpr body           `thenTM` \ body' ->
 361     returnTM (Lam (TyBinder tv') body')
 362
 363         -- Try for let-to-case (see notes in Simplify.lhs for why
 364         -- some let-to-case stuff is deferred to now).
 365 tidyCoreExpr (Let (NonRec bndr rhs) body)
 366   | willBeDemanded (getIdDemandInfo bndr) &&
 367     not rhs_is_whnf &&          -- Don't do it if RHS is already in WHNF
 368     typeOkForCase (idType bndr)
 369   = ASSERT( not (isUnpointedType (idType bndr)) )
 370     tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
 371   where
 372     rhs_is_whnf = case mkFormSummary rhs of
 373                         VarForm -> True
 374                         ValueForm -> True
 375                         other -> False
 376
 377 tidyCoreExpr (Let (NonRec bndr rhs) body)
 378   = tidyCoreExpr rhs            `thenTM` \ rhs' ->
 379     newId bndr                  $ \ bndr' ->
 380     tidyCoreExprEta body        `thenTM` \ body' ->
 381     returnTM (Let (NonRec bndr' rhs') body')
 382
 383 tidyCoreExpr (Let (Rec pairs) body)
 384   = newIds bndrs                $ \ bndrs' ->
 385     mapTM tidyCoreExpr rhss     `thenTM` \ rhss' ->
 386     tidyCoreExprEta body        `thenTM` \ body' ->
 387     returnTM (Let (Rec (bndrs' `zip` rhss')) body')
 388   where
 389     (bndrs, rhss) = unzip pairs
 390
 391 tidyCoreExpr (Note (Coerce to_ty from_ty) body)
 392   = tidyCoreExprEta body        `thenTM` \ body' ->
 393     tidyTy to_ty                `thenTM` \ to_ty' ->
 394     tidyTy from_ty              `thenTM` \ from_ty' ->
 395     returnTM (Note (Coerce to_ty' from_ty') body')
 396
 397 tidyCoreExpr (Note note body)
 398   = tidyCoreExprEta body        `thenTM` \ body' ->
 399     returnTM (Note note body')
 400
 401 -- Wierd case for par, seq, fork etc. See notes above.
 402 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
 403   | funnyParallelOp op
 404   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 405     newId binder                        $ \ binder' ->
 406     tidyCoreExprEta rhs                 `thenTM` \ rhs' ->
 407     returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
 408
 409 -- Eliminate polymorphic case, for which we can't generate code just yet
 410 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
 411   | not (typeOkForCase (idType deflt_bndr))
 412   = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $
 413     case scrut of
 414         Var v -> lookupId v     `thenTM` \ v' ->
 415                  extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
 416         other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
 417
 418 tidyCoreExpr (Case scrut alts)
 419   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 420     tidy_alts scrut' alts               `thenTM` \ alts' ->
 421     returnTM (Case scrut' alts')
 422   where
 423     tidy_alts scrut (AlgAlts alts deflt)
 424         = mapTM tidy_alg_alt alts       `thenTM` \ alts' ->
 425           tidy_deflt scrut deflt        `thenTM` \ deflt' ->
 426           returnTM (AlgAlts alts' deflt')
 427
 428     tidy_alts scrut (PrimAlts alts deflt)
 429         = mapTM tidy_prim_alt alts      `thenTM` \ alts' ->
 430           tidy_deflt scrut deflt        `thenTM` \ deflt' ->
 431           returnTM (PrimAlts alts' deflt')
 432
 433     tidy_alg_alt (con,bndrs,rhs) = newIds bndrs         $ \ bndrs' ->
 434                                    tidyCoreExprEta rhs  `thenTM` \ rhs' ->
 435                                    returnTM (con, bndrs', rhs')
 436
 437     tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs       `thenTM` \ rhs' ->
 438                               returnTM (lit,rhs')
 439
 440         -- We convert   case x of {...; x' -> ...x'...}
 441         --      to
 442         --              case x of {...; _  -> ...x... }
 443         --
 444         -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
 445         -- It's quite easily done: simply extend the environment to bind the
 446         -- default binder to the scrutinee.
 447
 448     tidy_deflt scrut NoDefault = returnTM NoDefault
 449     tidy_deflt scrut (BindDefault bndr rhs)
 450         = newId bndr                            $ \ bndr' ->
 451           extend_env (tidyCoreExprEta rhs)      `thenTM` \ rhs' ->
 452           returnTM (BindDefault bndr' rhs')
 453         where
 454           extend_env = case scrut of
 455                             Var v -> extendEnvTM bndr v
 456                             other -> \x -> x
 457
 458 tidyCoreExprEta e = tidyCoreExpr e      `thenTM` \ e' ->
 459                     returnTM (etaCoreExpr e')
 460 \end{code}
 461
 462 Arguments
 463 ~~~~~~~~~
 464 \begin{code}
 465 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
 466
 467 tidyCoreArg (VarArg v)
 468   = lookupId v  `thenTM` \ v' ->
 469     returnTM (VarArg v')
 470
 471 tidyCoreArg (LitArg lit)
 472   = litToRep lit                `thenTM` \ (lit_ty, lit_expr) ->
 473     case lit_expr of
 474         Var v -> returnTM (VarArg v)
 475         Lit l -> returnTM (LitArg l)
 476         other -> addTopFloat lit_ty lit_expr    `thenTM` \ v ->
 477                  returnTM (VarArg v)
 478
 479 tidyCoreArg (TyArg ty)   = tidyTy ty    `thenTM` \ ty' ->
 480                            returnTM (TyArg ty')
 481 \end{code}
 482
 483 \begin{code}
 484 tidyPrimOp (CCallOp fn casm gc tys ty)
 485   = mapTM tidyTy tys    `thenTM` \ tys' ->
 486     tidyTy ty           `thenTM` \ ty' ->
 487     returnTM (CCallOp fn casm gc tys' ty')
 488
 489 tidyPrimOp other_prim_op = returnTM other_prim_op
 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)
 508   = returnTM (stringTy, rhs)
 509   where
 510     rhs = if (any is_NUL (_UNPK_ s))
 511
 512           then   -- Must cater for NULs in literal string
 513                 mkGenApp (Var unpackCString2Id)
 514                          [LitArg (MachStr s),
 515                           LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
 516
 517           else  -- No NULs in the string
 518                 App (Var unpackCStringId) (LitArg (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         = Prim Int2IntegerOp [LitArg (mkMachInt i)]
 539
 540         | otherwise                     -- Big, so start from a string
 541         = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
 542
 543
 544 litToRep (NoRepRational r rational_ty)
 545   = tidyCoreArg (LitArg (NoRepInteger (numerator   r) integer_ty))      `thenTM` \ num_arg ->
 546     tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty))      `thenTM` \ denom_arg ->
 547     returnTM (rational_ty, Con ratio_data_con [TyArg 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 && uniqueOf tycon == ratioTyConKey)
 553                (con, i_ty)
 554
 555           _ -> (panic "ratio_data_con", panic "integer_ty")
 556
 557 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
 558 \end{code}
 559
 560 \begin{code}
 561 funnyParallelOp SeqOp  = True
 562 funnyParallelOp ParOp  = True
 563 funnyParallelOp ForkOp = True
 564 funnyParallelOp _      = False
 565 \end{code}
 566
 567
 568 %************************************************************************
 569 %*                                                                      *
 570 \subsection{The monad}
 571 %*                                                                      *
 572 %************************************************************************
 573
 574 \begin{code}
 575 type TidyM a state =  Module
 576                       -> UniqFM CoreBinder              -- Maps Ids to Ids, TyVars to TyVars etc
 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 CoreBinding)            -- Floats
 584
 585
 586 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
 587
 588 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
 589 initTM mod env m
 590   = case m mod env initialTopTidyUnique of
 591         (result, _) -> result
 592
 593 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
 594 initNestedTM m mod env global_us
 595   = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
 596         (result, (global_us', _, floats)) -> ((result, floats), global_us')
 597
 598 returnTM v mod env usf = (v, usf)
 599 thenTM m k mod env usf = case m mod env usf of
 600                            (r, usf') -> k r mod env usf'
 601
 602 mapTM f []     = returnTM []
 603 mapTM f (x:xs) = f x    `thenTM` \ r ->
 604                  mapTM f xs     `thenTM` \ rs ->
 605                  returnTM (r:rs)
 606 \end{code}
 607
 608
 609 \begin{code}
 610 -- Need to extend the environment when we munge a binder, so that occurrences
 611 -- of the binder will print the correct way (i.e. as a global not a local)
 612 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
 613 mungeTopBinder id thing_inside mod env us
 614   =     -- Give it a new print-name unless it's an exported thing
 615         -- setNameVisibility also does the local/global thing
 616     let
 617         (id', us')  | isExported id = (id, us)
 618                     | otherwise
 619                     = (setIdVisibility (Just mod) us id,
 620                        incrUnique us)
 621         new_env    = addToUFM env id (ValBinder id')
 622     in
 623     thing_inside id' mod new_env us'
 624
 625 mungeTopBinders []     k = k []
 626 mungeTopBinders (b:bs) k = mungeTopBinder b     $ \ b' ->
 627                            mungeTopBinders bs   $ \ bs' ->
 628                            k (b' : bs')
 629
 630 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
 631 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
 632   = let
 633         gus'      = incrUnique gus
 634         lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
 635         lit_id    = setIdVisibility (Just mod) gus lit_local
 636     in
 637     (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
 638
 639 lookupId :: Id -> TidyM Id state
 640 lookupId v mod env usf
 641   = case lookupUFM env v of
 642         Nothing             -> (v, usf)
 643         Just (ValBinder v') -> (v', usf)
 644
 645 extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
 646 extendEnvTM v v' m mod env usf
 647   = m mod (addOneToIdEnv env v (ValBinder v')) usf
 648 \end{code}
 649
 650
 651 Making new local binders
 652 ~~~~~~~~~~~~~~~~~~~~~~~~
 653 \begin{code}
 654 newId id thing_inside mod env (gus, local_uniq, floats)
 655   = let
 656         -- Give the Id a fresh print-name, *and* rename its type
 657         local_uniq'  = incrUnique local_uniq
 658         name'        = setNameVisibility Nothing local_uniq (getName id)
 659         ty'          = nmbr_ty env local_uniq' (idType id)
 660         id'          = mkUserId name' ty'
 661                        -- NB: This throws away the IdInfo of the Id, which we
 662                        -- no longer need.  That means we don't need to
 663                        -- run over it with env, nor renumber it
 664                        --
 665                        -- NB: the Id's unique remains unchanged; it's only
 666                        -- its print name that is affected by local_uniq
 667
 668         env'         = addToUFM env id (ValBinder id')
 669     in
 670     thing_inside id' mod env' (gus, local_uniq', floats)
 671
 672 newIds [] thing_inside
 673   = thing_inside []
 674 newIds (bndr:bndrs) thing_inside
 675   = newId bndr          $ \ bndr' ->
 676     newIds bndrs        $ \ bndrs' ->
 677     thing_inside (bndr' : bndrs')
 678
 679
 680 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
 681   = let
 682         local_uniq' = incrUnique local_uniq
 683         tyvar'      = nameTyVar tyvar (uniqToOccName local_uniq)
 684         env'        = addToUFM env tyvar (TyBinder tyvar')
 685     in
 686     thing_inside tyvar' mod env' (gus, local_uniq', floats)
 687 \end{code}
 688
 689 Re-numbering types
 690 ~~~~~~~~~~~~~~~~~~
 691 \begin{code}
 692 tidyTy ty mod env usf@(_, local_uniq, _)
 693   = (nmbr_ty env local_uniq ty, usf)
 694         -- We can use local_uniq as a base for renaming forall'd variables
 695         -- in the type; we don't need to know how many are consumed.
 696
 697 -- This little impedance-matcher calls nmbrType with the right arguments
 698 nmbr_ty env uniq ty
 699   = nmbrType tv_env uniq ty
 700   where
 701     tv_env :: TyVar -> TyVar
 702     tv_env tyvar = case lookupUFM env tyvar of
 703                         Just (TyBinder tyvar') -> tyvar'
 704                         other                  -> tyvar
 705 \end{code}
 706
 707