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