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