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 #include "HsVersions.h"
   8
   9 module SimplCore ( core2core ) where
  10
  11 IMP_Ubiq(){-uitous-}
  12 IMPORT_1_3(IO(hPutStr,stderr))
  13
  14 import AnalFBWW         ( analFBWW )
  15 import Bag              ( isEmptyBag, foldBag )
  16 import BinderInfo       ( BinderInfo{-instance Outputable-} )
  17 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
  18                           opt_D_show_passes,
  19                           opt_D_simplifier_stats,
  20                           opt_D_verbose_core2core,
  21                           opt_DoCoreLinting,
  22                           opt_FoldrBuildOn,
  23                           opt_ReportWhyUnfoldingsDisallowed,
  24                           opt_ShowImportSpecs,
  25                           opt_LiberateCaseThreshold
  26                         )
  27 import CoreLint         ( lintCoreBindings )
  28 import CoreSyn
  29 import CoreUtils        ( coreExprType )
  30 import CoreUnfold
  31 import Literal          ( Literal(..), literalType, mkMachInt )
  32 import ErrUtils         ( ghcExit )
  33 import FiniteMap        ( FiniteMap )
  34 import FloatIn          ( floatInwards )
  35 import FloatOut         ( floatOutwards )
  36 import FoldrBuildWW     ( mkFoldrBuildWW )
  37 import Id               ( mkSysLocal, setIdVisibility,
  38                           nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
  39                           lookupIdEnv, SYN_IE(IdEnv),
  40                           GenId{-instance Outputable-}
  41                         )
  42 import Name             ( isExported, isLocallyDefined )
  43 import TyCon            ( TyCon )
  44 import PrimOp           ( PrimOp(..) )
  45 import PrelVals         ( unpackCStringId, unpackCString2Id,
  46                           integerZeroId, integerPlusOneId,
  47                           integerPlusTwoId, integerMinusOneId
  48                         )
  49 import Type             ( maybeAppDataTyCon, getAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts )
  50 import TysWiredIn       ( stringTy )
  51 import LiberateCase     ( liberateCase )
  52 import MagicUFs         ( MagicUnfoldingFun )
  53 import Outputable       ( Outputable(..){-instance * (,) -} )
  54 import PprCore
  55 import PprStyle         ( PprStyle(..) )
  56 import PprType          ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
  57 import Pretty           ( ppShow, ppAboves, ppAbove, ppCat, ppStr )
  58 import SAT              ( doStaticArgs )
  59 import SimplMonad       ( zeroSimplCount, showSimplCount, SimplCount )
  60 import SimplPgm         ( simplifyPgm )
  61 import Specialise
  62 import SpecUtils        ( pprSpecErrs )
  63 import StrictAnal       ( saWwTopBinds )
  64 import TyVar            ( nullTyVarEnv, GenTyVar{-instance Eq-} )
  65 import Unique           ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
  66 import UniqSupply       ( splitUniqSupply, getUnique )
  67 import Util             ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic )
  68 import SrcLoc           ( noSrcLoc )
  69 import Constants        ( tARGET_MIN_INT, tARGET_MAX_INT )
  70 import Bag
  71 import Maybes
  72
  73
  74 #ifndef OMIT_DEFORESTER
  75 import Deforest         ( deforestProgram )
  76 import DefUtils         ( deforestable )
  77 #endif
  78
  79 \end{code}
  80
  81 \begin{code}
  82 core2core :: [CoreToDo]                 -- spec of what core-to-core passes to do
  83           -> FAST_STRING                -- module name (profiling only)
  84           -> PprStyle                   -- printing style (for debugging only)
  85           -> UniqSupply         -- a name supply
  86           -> [TyCon]                    -- local data tycons and tycon specialisations
  87           -> FiniteMap TyCon [(Bool, [Maybe Type])]
  88           -> [CoreBinding]              -- input...
  89           -> IO
  90               ([CoreBinding],           -- results: program, plus...
  91               SpecialiseData)           --  specialisation data
  92
  93 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
  94   =     -- Print heading
  95      (if opt_D_verbose_core2core then
  96             hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
  97       else return ())                                    >>
  98
  99         -- Do the main business
 100      foldl_mn do_core_pass
 101                 (binds, us1, init_specdata, zeroSimplCount)
 102                 core_todos
 103                 >>= \ (processed_binds, _, spec_data, simpl_stats) ->
 104
 105         -- Do the final tidy-up
 106      let
 107         final_binds = tidyCorePgm module_name us2 processed_binds
 108      in
 109
 110         -- Report statistics
 111      (if  opt_D_simplifier_stats then
 112          hPutStr stderr ("\nSimplifier Stats:\n")       >>
 113          hPutStr stderr (showSimplCount simpl_stats)    >>
 114          hPutStr stderr "\n"
 115       else return ())                                           >>
 116
 117         --
 118     return (final_binds, spec_data)
 119   where
 120     (us1, us2) = splitUniqSupply us
 121     init_specdata = initSpecData local_tycons tycon_specs
 122
 123     -------------
 124     core_linter = if opt_DoCoreLinting
 125                   then lintCoreBindings ppr_style
 126                   else ( \ whodunnit spec_done binds -> binds )
 127
 128     --------------
 129     do_core_pass info@(binds, us, spec_data, simpl_stats) to_do
 130       = let
 131             (us1, us2) = splitUniqSupply us
 132         in
 133         case to_do of
 134           CoreDoSimplify simpl_sw_chkr
 135             -> _scc_ "CoreSimplify"
 136                begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 137                                          then " (foldr/build)" else "") >>
 138                case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
 139                  (p, it_cnt, simpl_stats2)
 140                    -> end_pass False us2 p spec_data simpl_stats2
 141                                ("Simplify (" ++ show it_cnt ++ ")"
 142                                  ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 143                                     then " foldr/build" else "")
 144
 145           CoreDoFoldrBuildWorkerWrapper
 146             -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
 147                begin_pass "FBWW" >>
 148                case (mkFoldrBuildWW us1 binds) of { binds2 ->
 149                end_pass False us2 binds2 spec_data simpl_stats "FBWW" }
 150
 151           CoreDoFoldrBuildWWAnal
 152             -> _scc_ "CoreDoFoldrBuildWWAnal"
 153                begin_pass "AnalFBWW" >>
 154                case (analFBWW binds) of { binds2 ->
 155                end_pass False us2 binds2 spec_data simpl_stats "AnalFBWW" }
 156
 157           CoreLiberateCase
 158             -> _scc_ "LiberateCase"
 159                begin_pass "LiberateCase" >>
 160                case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
 161                end_pass False us2 binds2 spec_data simpl_stats "LiberateCase" }
 162
 163           CoreDoFloatInwards
 164             -> _scc_ "FloatInwards"
 165                begin_pass "FloatIn" >>
 166                case (floatInwards binds) of { binds2 ->
 167                end_pass False us2 binds2 spec_data simpl_stats "FloatIn" }
 168
 169           CoreDoFullLaziness
 170             -> _scc_ "CoreFloating"
 171                begin_pass "FloatOut" >>
 172                case (floatOutwards us1 binds) of { binds2 ->
 173                end_pass False us2 binds2 spec_data simpl_stats "FloatOut" }
 174
 175           CoreDoStaticArgs
 176             -> _scc_ "CoreStaticArgs"
 177                begin_pass "StaticArgs" >>
 178                case (doStaticArgs binds us1) of { binds2 ->
 179                end_pass False us2 binds2 spec_data simpl_stats "StaticArgs" }
 180                 -- Binds really should be dependency-analysed for static-
 181                 -- arg transformation... Not to worry, they probably are.
 182                 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
 183
 184           CoreDoStrictness
 185             -> _scc_ "CoreStranal"
 186                begin_pass "StrAnal" >>
 187                case (saWwTopBinds us1 binds) of { binds2 ->
 188                end_pass False us2 binds2 spec_data simpl_stats "StrAnal" }
 189
 190           CoreDoSpecialising
 191             -> _scc_ "Specialise"
 192                begin_pass "Specialise" >>
 193                case (specProgram us1 binds spec_data) of {
 194                  (p, spec_data2@(SpecData _ spec_noerrs _ _ _
 195                                           spec_errs spec_warn spec_tyerrs)) ->
 196
 197                    -- if we got errors, we die straight away
 198                    (if not spec_noerrs ||
 199                        (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
 200                         hPutStr stderr (ppShow 1000 {-pprCols-}
 201                             (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
 202                         >> hPutStr stderr "\n"
 203                     else
 204                         return ()) >>
 205
 206                    (if not spec_noerrs then -- Stop here if specialisation errors occured
 207                         ghcExit 1
 208                    else
 209                         return ()) >>
 210
 211                    end_pass False us2 p spec_data2 simpl_stats "Specialise"
 212                }
 213
 214           CoreDoDeforest
 215 #if OMIT_DEFORESTER
 216             -> error "ERROR: CoreDoDeforest: not built into compiler\n"
 217 #else
 218             -> _scc_ "Deforestation"
 219                begin_pass "Deforestation" >>
 220                case (deforestProgram binds us1) of { binds2 ->
 221                end_pass False us2 binds2 spec_data simpl_stats "Deforestation" }
 222 #endif
 223
 224           CoreDoPrintCore       -- print result of last pass
 225             -> end_pass True us2 binds spec_data simpl_stats "Print"
 226
 227     -------------------------------------------------
 228
 229     begin_pass
 230       = if opt_D_show_passes
 231         then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
 232         else \ what -> return ()
 233
 234     end_pass print us2 binds2
 235              spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
 236              simpl_stats2 what
 237       = -- report verbosely, if required
 238         (if (opt_D_verbose_core2core && not print) ||
 239             (print && not opt_D_verbose_core2core)
 240          then
 241             hPutStr stderr ("\n*** "++what++":\n")
 242                 >>
 243             hPutStr stderr (ppShow 1000
 244                 (ppAboves (map (pprCoreBinding ppr_style) binds2)))
 245                 >>
 246             hPutStr stderr "\n"
 247          else
 248             return ()) >>
 249         let
 250             linted_binds = core_linter what spec_done binds2
 251         in
 252         return
 253         (linted_binds,  -- processed binds, possibly run thru CoreLint
 254          us2,           -- UniqueSupply for the next guy
 255          spec_data2,    -- possibly-updated specialisation info
 256          simpl_stats2   -- accumulated simplifier stats
 257         )
 258
 259 -- here so it can be inlined...
 260 foldl_mn f z []     = return z
 261 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 262                       foldl_mn f zz xs
 263 \end{code}
 264
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 Several tasks are done by @tidyCorePgm@
 274
 275 1.  Eliminate indirections.  The point here is to transform
 276         x_local = E
 277         x_exported = x_local
 278     ==>
 279         x_exported = E
 280
 281 2.  Make certain top-level bindings into Globals. The point is that
 282     Global things get externally-visible labels at code generation
 283     time
 284
 285 3.  Make the representation of NoRep literals explicit, and
 286     float their bindings to the top level
 287
 288 4.  Convert
 289         case x of {...; x' -> ...x'...}
 290     ==>
 291         case x of {...; _  -> ...x... }
 292     See notes in SimplCase.lhs, near simplDefault for the reasoning here.
 293
 294 5.  *Mangle* cases involving fork# and par# in the discriminant.  The
 295     original templates for these primops (see @PrelVals.lhs@) constructed
 296     case expressions with boolean results solely to fool the strictness
 297     analyzer, the simplifier, and anyone else who might want to fool with
 298     the evaluation order.  At this point in the compiler our evaluation
 299     order is safe.  Therefore, we convert expressions of the form:
 300
 301         case par# e of
 302           True -> rhs
 303           False -> parError#
 304     ==>
 305         case par# e of
 306           _ -> rhs
 307
 308 6.      Eliminate polymorphic case expressions.  We can't generate code for them yet.
 309
 310 Eliminate indirections
 311 ~~~~~~~~~~~~~~~~~~~~~~
 312 In @elimIndirections@, we look for things at the top-level of the form...
 313 \begin{verbatim}
 314         x_local = ....
 315         x_exported = x_local
 316 \end{verbatim}
 317 In cases we find like this, we go {\em backwards} and replace
 318 \tr{x_local} with \tr{x_exported}.  This save a gratuitous jump
 319 (from \tr{x_exported} to \tr{x_local}), and makes strictness
 320 information propagate better.
 321
 322 We rely on prior eta reduction to simplify things like
 323 \begin{verbatim}
 324         x_exported = /\ tyvars -> x_local tyvars
 325 ==>
 326         x_exported = x_local
 327 \end{verbatim}
 328
 329 If more than one exported thing is equal to a local thing (i.e., the
 330 local thing really is shared), then we do one only:
 331 \begin{verbatim}
 332         x_local = ....
 333         x_exported1 = x_local
 334         x_exported2 = x_local
 335 ==>
 336         x_exported1 = ....
 337
 338         x_exported2 = x_exported1
 339 \end{verbatim}
 340
 341 There's a possibility of leaving unchanged something like this:
 342 \begin{verbatim}
 343         x_local = ....
 344         x_exported1 = x_local Int
 345 \end{verbatim}
 346 By the time we've thrown away the types in STG land this
 347 could be eliminated.  But I don't think it's very common
 348 and it's dangerous to do this fiddling in STG land
 349 because we might elminate a binding that's mentioned in the
 350 unfolding for something.
 351
 352 General Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
 353 Then blast the whole program (LHSs as well as RHSs) with it.
 354
 355
 356
 357 \begin{code}
 358 tidyCorePgm :: Module -> UniqSupply -> [CoreBinding] -> [CoreBinding]
 359
 360 tidyCorePgm mod us binds_in
 361   = initTM mod indirection_env us $
 362     tidyTopBindings (catMaybes reduced_binds)   `thenTM` \ binds ->
 363     returnTM (bagToList binds)
 364   where
 365     (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
 366
 367     try_bind :: IdEnv Id -> CoreBinding -> (IdEnv Id, Maybe CoreBinding)
 368     try_bind env_so_far
 369              (NonRec exported_binder (Var local_id))
 370         | isExported exported_binder &&         -- Only if this is exported
 371           isLocallyDefined local_id &&          -- Only if this one is defined in this
 372           not (isExported local_id) &&          --      module, so that we *can* change its
 373                                                 --      binding to be the exported thing!
 374           not (maybeToBool (lookupIdEnv env_so_far local_id))
 375                                                 -- Only if not already substituted for
 376         = (addOneToIdEnv env_so_far local_id exported_binder, Nothing)
 377
 378     try_bind env_so_far bind
 379         = (env_so_far, Just bind)
 380 \end{code}
 381
 382 Top level bindings
 383 ~~~~~~~~~~~~~~~~~~
 384 \begin{code}
 385 tidyTopBindings [] = returnTM emptyBag
 386 tidyTopBindings (b:bs)
 387   = tidyTopBinding  b           $
 388     tidyTopBindings bs
 389
 390 tidyTopBinding :: CoreBinding
 391                -> TidyM (Bag CoreBinding)
 392                -> TidyM (Bag CoreBinding)
 393
 394 tidyTopBinding (NonRec bndr rhs) thing_inside
 395   = getFloats (tidyCoreExpr rhs)                `thenTM` \ (rhs',floats) ->
 396     mungeTopBinder bndr                         $ \ bndr' ->
 397     thing_inside                                `thenTM` \ binds ->
 398     returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
 399
 400 tidyTopBinding (Rec pairs) thing_inside
 401   = mungeTopBinders binders                     $ \ binders' ->
 402     getFloats (mapTM tidyCoreExpr rhss)         `thenTM` \ (rhss', floats) ->
 403     thing_inside                                `thenTM` \ binds_inside ->
 404     returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
 405   where
 406     (binders, rhss) = unzip pairs
 407 \end{code}
 408
 409
 410 Local Bindings
 411 ~~~~~~~~~~~~~~
 412 \begin{code}
 413 tidyCoreBinding (NonRec bndr rhs)
 414   = tidyCoreExpr rhs            `thenTM` \ rhs' ->
 415     returnTM (NonRec bndr rhs')
 416
 417 tidyCoreBinding (Rec pairs)
 418   = mapTM do_one pairs  `thenTM` \ pairs' ->
 419     returnTM (Rec pairs')
 420   where
 421     do_one (bndr,rhs) = tidyCoreExpr rhs        `thenTM` \ rhs' ->
 422                         returnTM (bndr, rhs')
 423
 424 \end{code}
 425
 426
 427 Expressions
 428 ~~~~~~~~~~~
 429 \begin{code}
 430 tidyCoreExpr (Var v) = lookupTM v       `thenTM` \ v' ->
 431                        returnTM (Var v')
 432
 433 tidyCoreExpr (Lit lit)
 434   = litToRep lit        `thenTM` \ (_, lit_expr) ->
 435     returnTM lit_expr
 436
 437 tidyCoreExpr (App fun arg)
 438   = tidyCoreExpr fun    `thenTM` \ fun' ->
 439     tidyCoreArg arg     `thenTM` \ arg' ->
 440     returnTM (App fun' arg')
 441
 442 tidyCoreExpr (Con con args)
 443   = mapTM tidyCoreArg args      `thenTM` \ args' ->
 444     returnTM (Con con args')
 445
 446 tidyCoreExpr (Prim prim args)
 447   = mapTM tidyCoreArg args      `thenTM` \ args' ->
 448     returnTM (Prim prim args')
 449
 450 tidyCoreExpr (Lam bndr body)
 451   = tidyCoreExpr body           `thenTM` \ body' ->
 452     returnTM (Lam bndr body')
 453
 454 tidyCoreExpr (Let bind body)
 455   = tidyCoreBinding bind        `thenTM` \ bind' ->
 456     tidyCoreExpr body           `thenTM` \ body' ->
 457     returnTM (Let bind' body')
 458
 459 tidyCoreExpr (SCC cc body)
 460   = tidyCoreExpr body           `thenTM` \ body' ->
 461     returnTM (SCC cc body')
 462
 463 tidyCoreExpr (Coerce coercion ty body)
 464   = tidyCoreExpr body           `thenTM` \ body' ->
 465     returnTM (Coerce coercion ty body')
 466
 467 -- Wierd case for par, seq, fork etc. See notes above.
 468 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
 469   | funnyParallelOp op
 470   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 471     tidyCoreExpr rhs                    `thenTM` \ rhs' ->
 472     returnTM (Case scrut' (PrimAlts [] (BindDefault binder rhs')))
 473
 474 -- Eliminate polymorphic case, for which we can't generate code just yet
 475 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
 476   | not (maybeToBool (maybeAppSpecDataTyConExpandingDicts (coreExprType scrut)))
 477   = pprTrace "Warning: discarding polymophic case:" (ppr PprDebug scrut) $
 478     case scrut of
 479         Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs)
 480         other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
 481
 482 tidyCoreExpr (Case scrut alts)
 483   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 484     tidy_alts alts                      `thenTM` \ alts' ->
 485     returnTM (Case scrut' alts')
 486   where
 487     tidy_alts (AlgAlts alts deflt)
 488         = mapTM tidy_alg_alt alts       `thenTM` \ alts' ->
 489           tidy_deflt deflt              `thenTM` \ deflt' ->
 490           returnTM (AlgAlts alts' deflt')
 491
 492     tidy_alts (PrimAlts alts deflt)
 493         = mapTM tidy_prim_alt alts      `thenTM` \ alts' ->
 494           tidy_deflt deflt              `thenTM` \ deflt' ->
 495           returnTM (PrimAlts alts' deflt')
 496
 497     tidy_alg_alt (con,bndrs,rhs) = tidyCoreExpr rhs     `thenTM` \ rhs' ->
 498                                    returnTM (con,bndrs,rhs')
 499
 500     tidy_prim_alt (lit,rhs) = tidyCoreExpr rhs  `thenTM` \ rhs' ->
 501                               returnTM (lit,rhs')
 502
 503         -- We convert   case x of {...; x' -> ...x'...}
 504         --      to
 505         --              case x of {...; _  -> ...x... }
 506         --
 507         -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
 508         -- It's quite easily done: simply extend the environment to bind the
 509         -- default binder to the scrutinee.
 510
 511     tidy_deflt NoDefault = returnTM NoDefault
 512     tidy_deflt (BindDefault bndr rhs)
 513         = extend_env (tidyCoreExpr rhs) `thenTM` \ rhs' ->
 514           returnTM (BindDefault bndr rhs')
 515         where
 516           extend_env = case scrut of
 517                             Var v -> extendEnvTM bndr v
 518                             other -> \x -> x
 519 \end{code}
 520
 521 Arguments
 522 ~~~~~~~~~
 523 \begin{code}
 524 tidyCoreArg :: CoreArg -> TidyM CoreArg
 525
 526 tidyCoreArg (VarArg v)
 527   = lookupTM v  `thenTM` \ v' ->
 528     returnTM (VarArg v')
 529
 530 tidyCoreArg (LitArg lit)
 531   = litToRep lit                `thenTM` \ (lit_ty, lit_expr) ->
 532     case lit_expr of
 533         Var v -> returnTM (VarArg v)
 534         Lit l -> returnTM (LitArg l)
 535         other -> addTopFloat lit_ty lit_expr    `thenTM` \ v ->
 536                  returnTM (VarArg v)
 537
 538 tidyCoreArg (TyArg ty)   = returnTM (TyArg ty)
 539 tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
 540 \end{code}
 541
 542
 543 %************************************************************************
 544 %*                                                                      *
 545 \subsection[coreToStg-lits]{Converting literals}
 546 %*                                                                      *
 547 %************************************************************************
 548
 549 Literals: the NoRep kind need to be de-no-rep'd.
 550 We always replace them with a simple variable, and float a suitable
 551 binding out to the top level.
 552
 553 \begin{code}
 554
 555 litToRep :: Literal -> TidyM (Type, CoreExpr)
 556
 557 litToRep (NoRepStr s)
 558   = returnTM (stringTy, rhs)
 559   where
 560     rhs = if (any is_NUL (_UNPK_ s))
 561
 562           then   -- Must cater for NULs in literal string
 563                 mkGenApp (Var unpackCString2Id)
 564                          [LitArg (MachStr s),
 565                           LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
 566
 567           else  -- No NULs in the string
 568                 App (Var unpackCStringId) (LitArg (MachStr s))
 569
 570     is_NUL c = c == '\0'
 571 \end{code}
 572
 573 If an Integer is small enough (Haskell implementations must support
 574 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 575 otherwise, wrap with @litString2Integer@.
 576
 577 \begin{code}
 578 litToRep (NoRepInteger i integer_ty)
 579   = returnTM (integer_ty, rhs)
 580   where
 581     rhs | i == 0    = Var integerZeroId   -- Extremely convenient to look out for
 582         | i == 1    = Var integerPlusOneId  -- a few very common Integer literals!
 583         | i == 2    = Var integerPlusTwoId
 584         | i == (-1) = Var integerMinusOneId
 585
 586         | i > tARGET_MIN_INT &&         -- Small enough, so start from an Int
 587           i < tARGET_MAX_INT
 588         = Prim Int2IntegerOp [LitArg (mkMachInt i)]
 589
 590         | otherwise                     -- Big, so start from a string
 591         = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
 592
 593
 594 litToRep (NoRepRational r rational_ty)
 595   = tidyCoreArg (LitArg (NoRepInteger (numerator   r) integer_ty))      `thenTM` \ num_arg ->
 596     tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty))      `thenTM` \ denom_arg ->
 597     returnTM (rational_ty, Con ratio_data_con [num_arg, denom_arg])
 598   where
 599     (ratio_data_con, integer_ty)
 600       = case (maybeAppDataTyCon rational_ty) of
 601           Just (tycon, [i_ty], [con])
 602             -> ASSERT(is_integer_ty i_ty && uniqueOf tycon == ratioTyConKey)
 603                (con, i_ty)
 604
 605           _ -> (panic "ratio_data_con", panic "integer_ty")
 606
 607     is_integer_ty ty
 608       = case (maybeAppDataTyCon ty) of
 609           Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
 610           _                   -> False
 611
 612 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
 613 \end{code}
 614
 615 \begin{code}
 616 funnyParallelOp SeqOp  = True
 617 funnyParallelOp ParOp  = True
 618 funnyParallelOp ForkOp = True
 619 funnyParallelOp _      = False
 620 \end{code}
 621
 622
 623 %************************************************************************
 624 %*                                                                      *
 625 \subsection{The monad}
 626 %*                                                                      *
 627 %************************************************************************
 628
 629 \begin{code}
 630 type TidyM a =  Module
 631              -> IdEnv Id
 632              -> (UniqSupply, Bag CoreBinding)
 633              -> (a, (UniqSupply, Bag CoreBinding))
 634
 635 initTM mod env us m
 636   = case m mod env (us,emptyBag) of
 637         (result, (us',floats)) -> result
 638
 639 returnTM v mod env usf = (v, usf)
 640 thenTM m k mod env usf = case m mod env usf of
 641                            (r, usf') -> k r mod env usf'
 642
 643 mapTM f []     = returnTM []
 644 mapTM f (x:xs) = f x    `thenTM` \ r ->
 645                  mapTM f xs     `thenTM` \ rs ->
 646                  returnTM (r:rs)
 647 \end{code}
 648
 649
 650 \begin{code}
 651 getFloats :: TidyM a -> TidyM (a, Bag CoreBinding)
 652 getFloats m mod env (us,floats)
 653   = case m mod env (us,emptyBag) of
 654         (r, (us',floats')) -> ((r, floats'), (us',floats))
 655
 656
 657 -- Need to extend the environment when we munge a binder, so that occurrences
 658 -- of the binder will print the correct way (i.e. as a global not a local)
 659 mungeTopBinder :: Id -> (Id -> TidyM a) -> TidyM a
 660 mungeTopBinder id thing_inside mod env usf
 661   = case lookupIdEnv env id of
 662         Just global -> thing_inside global mod env usf
 663         Nothing     -> thing_inside new_global mod new_env usf
 664                     where
 665                        new_env    = addOneToIdEnv env id new_global
 666                        new_global = setIdVisibility mod id
 667
 668 mungeTopBinders []     k = k []
 669 mungeTopBinders (b:bs) k = mungeTopBinder b     $ \ b' ->
 670                            mungeTopBinders bs   $ \ bs' ->
 671                            k (b' : bs')
 672
 673 addTopFloat :: Type -> CoreExpr -> TidyM Id
 674 addTopFloat lit_ty lit_rhs mod env (us, floats)
 675   = (lit_id, (us', floats `snocBag` NonRec lit_id lit_rhs))
 676   where
 677     lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc
 678     lit_id = setIdVisibility mod lit_local
 679     (us', us1) = splitUniqSupply us
 680     uniq = getUnique us1
 681
 682 lookupTM v mod env usf
 683   = case lookupIdEnv env v of
 684         Nothing -> (v, usf)
 685         Just v' -> (v', usf)
 686
 687 extendEnvTM v v' m mod env usf
 688   = m mod (addOneToIdEnv env v v') usf
 689 \end{code}
 690
 691