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, mkIdWithNewName, getIdDemandInfo, idType,
  39                           nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
  40                           lookupIdEnv, SYN_IE(IdEnv), omitIfaceSigForId,
  41                           GenId{-instance Outputable-}, SYN_IE(Id)
  42                         )
  43 import IdInfo           ( willBeDemanded, DemandInfo )
  44 import Name             ( isExported, isLocallyDefined, SYN_IE(Module), NamedThing(..) )
  45 import TyCon            ( TyCon )
  46 import PrimOp           ( PrimOp(..) )
  47 import PrelVals         ( unpackCStringId, unpackCString2Id,
  48                           integerZeroId, integerPlusOneId,
  49                           integerPlusTwoId, integerMinusOneId
  50                         )
  51 import Type             ( maybeAppDataTyCon, isPrimType, SYN_IE(Type) )
  52 import TysWiredIn       ( stringTy )
  53 import LiberateCase     ( liberateCase )
  54 import MagicUFs         ( MagicUnfoldingFun )
  55 import Outputable       ( Outputable(..){-instance * (,) -} )
  56 import PprCore
  57 import PprStyle         ( PprStyle(..) )
  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-} )
  68 import UniqFM           ( Uniquable(..) )
  69 import UniqSupply       ( splitUniqSupply, getUnique, UniqSupply )
  70 import Util             ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic )
  71 import SrcLoc           ( noSrcLoc )
  72 import Constants        ( tARGET_MIN_INT, tARGET_MAX_INT )
  73 import Bag
  74 import Maybes
  75
  76
  77 #ifndef OMIT_DEFORESTER
  78 import Deforest         ( deforestProgram )
  79 import DefUtils         ( deforestable )
  80 #endif
  81
  82 \end{code}
  83
  84 \begin{code}
  85 core2core :: [CoreToDo]                 -- spec of what core-to-core passes to do
  86           -> FAST_STRING                -- module name (profiling only)
  87           -> PprStyle                   -- printing style (for debugging only)
  88           -> UniqSupply         -- a name supply
  89           -> [TyCon]                    -- local data tycons and tycon specialisations
  90           -> FiniteMap TyCon [(Bool, [Maybe Type])]
  91           -> [CoreBinding]              -- input...
  92           -> IO
  93               ([CoreBinding],           -- results: program, plus...
  94               SpecialiseData)           --  specialisation data
  95
  96 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
  97   =     -- Print heading
  98      (if opt_D_verbose_core2core then
  99             hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
 100       else return ())                                    >>
 101
 102         -- Do the main business
 103      --case (splitUniqSupply us) of { (us1,us2) ->
 104      foldl_mn do_core_pass
 105                 (binds, us, init_specdata, zeroSimplCount)
 106                 core_todos
 107                 >>= \ (processed_binds, us', spec_data, simpl_stats) ->
 108
 109         -- Do the final tidy-up
 110      let
 111         final_binds = core_linter "TidyCorePgm" True $
 112                       tidyCorePgm module_name us' processed_binds
 113      in
 114
 115         -- Report statistics
 116      (if  opt_D_simplifier_stats then
 117          hPutStr stderr ("\nSimplifier Stats:\n")       >>
 118          hPutStr stderr (showSimplCount simpl_stats)    >>
 119          hPutStr stderr "\n"
 120       else return ())                                           >>
 121
 122         --
 123     return (final_binds, spec_data) --}
 124   where
 125 --    (us1, us2) = splitUniqSupply us
 126     init_specdata = initSpecData local_tycons tycon_specs
 127
 128     -------------
 129     core_linter what spec_done
 130         = if opt_DoCoreLinting
 131           then (if opt_D_show_passes then
 132                                 trace ("\n*** Core Lint result of " ++ what)
 133                 else id
 134                )
 135               lintCoreBindings ppr_style what spec_done
 136           else id
 137
 138     --------------
 139     do_core_pass info@(binds, us, spec_data, simpl_stats) to_do =
 140 --     let
 141 --      (us1, us2) = splitUniqSupply us
 142 --     in
 143      case (splitUniqSupply us) of
 144       (us1,us2) ->
 145         case to_do of
 146           CoreDoSimplify simpl_sw_chkr
 147             -> _scc_ "CoreSimplify"
 148                begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 149                                          then " (foldr/build)" else "") >>
 150                case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
 151                  (p, it_cnt, simpl_stats2)
 152                    -> end_pass False us2 p spec_data simpl_stats2
 153                                ("Simplify (" ++ show it_cnt ++ ")"
 154                                  ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 155                                     then " foldr/build" else "")
 156
 157           CoreDoFoldrBuildWorkerWrapper
 158             -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
 159                begin_pass "FBWW" >>
 160                case (mkFoldrBuildWW us1 binds) of { binds2 ->
 161                end_pass False us2 binds2 spec_data simpl_stats "FBWW" }
 162
 163           CoreDoFoldrBuildWWAnal
 164             -> _scc_ "CoreDoFoldrBuildWWAnal"
 165                begin_pass "AnalFBWW" >>
 166                case (analFBWW binds) of { binds2 ->
 167                end_pass False us2 binds2 spec_data simpl_stats "AnalFBWW" }
 168
 169           CoreLiberateCase
 170             -> _scc_ "LiberateCase"
 171                begin_pass "LiberateCase" >>
 172                case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
 173                end_pass False us2 binds2 spec_data simpl_stats "LiberateCase" }
 174
 175           CoreDoFloatInwards
 176             -> _scc_ "FloatInwards"
 177                begin_pass "FloatIn" >>
 178                case (floatInwards binds) of { binds2 ->
 179                end_pass False us2 binds2 spec_data simpl_stats "FloatIn" }
 180
 181           CoreDoFullLaziness
 182             -> _scc_ "CoreFloating"
 183                begin_pass "FloatOut" >>
 184                case (floatOutwards us1 binds) of { binds2 ->
 185                end_pass False us2 binds2 spec_data simpl_stats "FloatOut" }
 186
 187           CoreDoStaticArgs
 188             -> _scc_ "CoreStaticArgs"
 189                begin_pass "StaticArgs" >>
 190                case (doStaticArgs binds us1) of { binds2 ->
 191                end_pass False us2 binds2 spec_data simpl_stats "StaticArgs" }
 192                 -- Binds really should be dependency-analysed for static-
 193                 -- arg transformation... Not to worry, they probably are.
 194                 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
 195
 196           CoreDoStrictness
 197             -> _scc_ "CoreStranal"
 198                begin_pass "StrAnal" >>
 199                case (saWwTopBinds us1 binds) of { binds2 ->
 200                end_pass False us2 binds2 spec_data simpl_stats "StrAnal" }
 201
 202           CoreDoSpecialising
 203             -> _scc_ "Specialise"
 204                begin_pass "Specialise" >>
 205                case (specProgram us1 binds spec_data) of {
 206                  (p, spec_data2@(SpecData _ spec_noerrs _ _ _
 207                                           spec_errs spec_warn spec_tyerrs)) ->
 208
 209                    -- if we got errors, we die straight away
 210                    (if not spec_noerrs ||
 211                        (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
 212                         hPutStr stderr (show
 213                             (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
 214                         >> hPutStr stderr "\n"
 215                     else
 216                         return ()) >>
 217
 218                    (if not spec_noerrs then -- Stop here if specialisation errors occured
 219                         ghcExit 1
 220                    else
 221                         return ()) >>
 222
 223                    end_pass False us2 p spec_data2 simpl_stats "Specialise"
 224                }
 225
 226           CoreDoDeforest
 227 #if OMIT_DEFORESTER
 228             -> error "ERROR: CoreDoDeforest: not built into compiler\n"
 229 #else
 230             -> _scc_ "Deforestation"
 231                begin_pass "Deforestation" >>
 232                case (deforestProgram binds us1) of { binds2 ->
 233                end_pass False us2 binds2 spec_data simpl_stats "Deforestation" }
 234 #endif
 235
 236           CoreDoPrintCore       -- print result of last pass
 237             -> end_pass True us2 binds spec_data simpl_stats "Print"
 238
 239     -------------------------------------------------
 240
 241     begin_pass
 242       = if opt_D_show_passes
 243         then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
 244         else \ what -> return ()
 245
 246     end_pass print us2 binds2
 247              spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
 248              simpl_stats2 what
 249       = -- report verbosely, if required
 250         (if (opt_D_verbose_core2core && not print) ||
 251             (print && not opt_D_verbose_core2core)
 252          then
 253             hPutStr stderr ("\n*** "++what++":\n")
 254                 >>
 255             hPutStr stderr (show
 256                 (vcat (map (pprCoreBinding ppr_style) binds2)))
 257                 >>
 258             hPutStr stderr "\n"
 259          else
 260             return ()) >>
 261         let
 262             linted_binds = core_linter what spec_done binds2
 263         in
 264         return
 265         (linted_binds,  -- processed binds, possibly run thru CoreLint
 266          us2,           -- UniqueSupply for the next guy
 267          spec_data2,    -- possibly-updated specialisation info
 268          simpl_stats2   -- accumulated simplifier stats
 269         )
 270
 271 -- here so it can be inlined...
 272 foldl_mn f z []     = return z
 273 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 274                       foldl_mn f zz xs
 275 \end{code}
 276
 277
 278
 279 %************************************************************************
 280 %*                                                                      *
 281 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
 282 %*                                                                      *
 283 %************************************************************************
 284
 285 Several tasks are done by @tidyCorePgm@
 286
 287 1.  Eliminate indirections.  The point here is to transform
 288         x_local = E
 289         x_exported = x_local
 290     ==>
 291         x_exported = E
 292
 293 2.  Make certain top-level bindings into Globals. The point is that
 294     Global things get externally-visible labels at code generation
 295     time
 296
 297 3.  Make the representation of NoRep literals explicit, and
 298     float their bindings to the top level
 299
 300 4.  Convert
 301         case x of {...; x' -> ...x'...}
 302     ==>
 303         case x of {...; _  -> ...x... }
 304     See notes in SimplCase.lhs, near simplDefault for the reasoning here.
 305
 306 5.  *Mangle* cases involving fork# and par# in the discriminant.  The
 307     original templates for these primops (see @PrelVals.lhs@) constructed
 308     case expressions with boolean results solely to fool the strictness
 309     analyzer, the simplifier, and anyone else who might want to fool with
 310     the evaluation order.  At this point in the compiler our evaluation
 311     order is safe.  Therefore, we convert expressions of the form:
 312
 313         case par# e of
 314           True -> rhs
 315           False -> parError#
 316     ==>
 317         case par# e of
 318           _ -> rhs
 319
 320 6.      Eliminate polymorphic case expressions.  We can't generate code for them yet.
 321
 322 7.      Do eta reduction for lambda abstractions appearing in:
 323                 - the RHS of case alternatives
 324                 - the body of a let
 325         These will otherwise turn into local bindings during Core->STG; better to
 326         nuke them if possible.   (In general the simplifier does eta expansion not
 327         eta reduction, up to this point.)
 328
 329 8.      Do let-to-case.  See notes in Simplify.lhs for why we defer let-to-case
 330         for multi-constructor types.
 331
 332
 333 Eliminate indirections
 334 ~~~~~~~~~~~~~~~~~~~~~~
 335 In @elimIndirections@, we look for things at the top-level of the form...
 336 \begin{verbatim}
 337         x_local = ....
 338         x_exported = x_local
 339 \end{verbatim}
 340 In cases we find like this, we go {\em backwards} and replace
 341 \tr{x_local} with \tr{x_exported}.  This save a gratuitous jump
 342 (from \tr{x_exported} to \tr{x_local}), and makes strictness
 343 information propagate better.
 344
 345 We rely on prior eta reduction to simplify things like
 346 \begin{verbatim}
 347         x_exported = /\ tyvars -> x_local tyvars
 348 ==>
 349         x_exported = x_local
 350 \end{verbatim}
 351
 352 If more than one exported thing is equal to a local thing (i.e., the
 353 local thing really is shared), then we do one only:
 354 \begin{verbatim}
 355         x_local = ....
 356         x_exported1 = x_local
 357         x_exported2 = x_local
 358 ==>
 359         x_exported1 = ....
 360
 361         x_exported2 = x_exported1
 362 \end{verbatim}
 363
 364 There's a possibility of leaving unchanged something like this:
 365 \begin{verbatim}
 366         x_local = ....
 367         x_exported1 = x_local Int
 368 \end{verbatim}
 369 By the time we've thrown away the types in STG land this
 370 could be eliminated.  But I don't think it's very common
 371 and it's dangerous to do this fiddling in STG land
 372 because we might elminate a binding that's mentioned in the
 373 unfolding for something.
 374
 375 General Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
 376 Then blast the whole program (LHSs as well as RHSs) with it.
 377
 378
 379
 380 \begin{code}
 381 tidyCorePgm :: Module -> UniqSupply -> [CoreBinding] -> [CoreBinding]
 382
 383 tidyCorePgm mod us binds_in
 384   = initTM mod indirection_env us $
 385     tidyTopBindings (catMaybes reduced_binds)   `thenTM` \ binds ->
 386     returnTM (bagToList binds)
 387   where
 388     (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
 389
 390     try_bind :: IdEnv Id -> CoreBinding -> (IdEnv Id, Maybe CoreBinding)
 391     try_bind env_so_far (NonRec exported_binder rhs)
 392         | isExported exported_binder &&         -- Only if this is exported
 393           maybeToBool maybe_rhs_id &&           --      and the RHS is a simple Id
 394
 395           isLocallyDefined rhs_id &&            -- Only if this one is defined in this
 396                                                 --      module, so that we *can* change its
 397                                                 --      binding to be the exported thing!
 398
 399           not (isExported rhs_id) &&            -- Only if this one is not itself exported,
 400                                                 --      since the transformation will nuke it
 401
 402           not (omitIfaceSigForId rhs_id) &&     -- Don't do the transformation if rhs_id is
 403                                                 --      something like a constructor, whose
 404                                                 --      definition is implicitly exported and
 405                                                 --      which must not vanish.
 406                 -- To illustrate the preceding check consider
 407                 --      data T = MkT Int
 408                 --      mkT = MkT
 409                 --      f x = MkT (x+1)
 410                 -- Here, we'll make a local, non-exported, defn for MkT, and without the
 411                 -- above condition we'll transform it to:
 412                 --      mkT = \x. MkT [x]
 413                 --      f = \y. mkT (y+1)
 414                 -- This is bad because mkT will get the IdDetails of MkT, and won't
 415                 -- be exported.  Also the code generator won't make a definition for
 416                 -- the MkT constructor.
 417                 -- Slightly gruesome, this.
 418
 419           not (maybeToBool (lookupIdEnv env_so_far rhs_id))
 420                                                 -- Only if not already substituted for
 421
 422         = (addOneToIdEnv env_so_far rhs_id new_rhs_id, Nothing)
 423         where
 424            maybe_rhs_id = case etaCoreExpr rhs of
 425                                 Var rhs_id -> Just rhs_id
 426                                 other      -> Nothing
 427            Just rhs_id  = maybe_rhs_id
 428            new_rhs_id   = mkIdWithNewName rhs_id (getName exported_binder)
 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