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