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-} )
  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   = exported_binder `replaceIdInfo`     getIdInfo rhs_id
 429                                           `replacePragmaInfo` getPragmaInfo rhs_id
 430                                 -- NB: we keep the Pragmas and IdInfo for the old rhs_id!
 431                                 -- This is important; it might be marked "no-inline" by
 432                                 -- the occurrence analyser (because it's recursive), and
 433                                 -- we must not lose that information.
 434
 435     try_bind env_so_far bind
 436         = (env_so_far, Just bind)
 437 \end{code}
 438
 439 Top level bindings
 440 ~~~~~~~~~~~~~~~~~~
 441 \begin{code}
 442 tidyTopBindings [] = returnTM emptyBag
 443 tidyTopBindings (b:bs)
 444   = tidyTopBinding  b           $
 445     tidyTopBindings bs
 446
 447 tidyTopBinding :: CoreBinding
 448                -> TidyM (Bag CoreBinding)
 449                -> TidyM (Bag CoreBinding)
 450
 451 tidyTopBinding (NonRec bndr rhs) thing_inside
 452   = getFloats (tidyCoreExpr rhs)                `thenTM` \ (rhs',floats) ->
 453     mungeTopBinder bndr                         $ \ bndr' ->
 454     thing_inside                                `thenTM` \ binds ->
 455     returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
 456
 457 tidyTopBinding (Rec pairs) thing_inside
 458   = mungeTopBinders binders                     $ \ binders' ->
 459     getFloats (mapTM tidyCoreExpr rhss)         `thenTM` \ (rhss', floats) ->
 460     thing_inside                                `thenTM` \ binds_inside ->
 461     returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
 462   where
 463     (binders, rhss) = unzip pairs
 464 \end{code}
 465
 466
 467 Local Bindings
 468 ~~~~~~~~~~~~~~
 469 \begin{code}
 470 tidyCoreBinding (NonRec bndr rhs)
 471   = tidyCoreExpr rhs            `thenTM` \ rhs' ->
 472     returnTM (NonRec bndr rhs')
 473
 474 tidyCoreBinding (Rec pairs)
 475   = mapTM do_one pairs  `thenTM` \ pairs' ->
 476     returnTM (Rec pairs')
 477   where
 478     do_one (bndr,rhs) = tidyCoreExpr rhs        `thenTM` \ rhs' ->
 479                         returnTM (bndr, rhs')
 480
 481 \end{code}
 482
 483
 484 Expressions
 485 ~~~~~~~~~~~
 486 \begin{code}
 487 tidyCoreExpr (Var v) = lookupTM v       `thenTM` \ v' ->
 488                        returnTM (Var v')
 489
 490 tidyCoreExpr (Lit lit)
 491   = litToRep lit        `thenTM` \ (_, lit_expr) ->
 492     returnTM lit_expr
 493
 494 tidyCoreExpr (App fun arg)
 495   = tidyCoreExpr fun    `thenTM` \ fun' ->
 496     tidyCoreArg arg     `thenTM` \ arg' ->
 497     returnTM (App fun' arg')
 498
 499 tidyCoreExpr (Con con args)
 500   = mapTM tidyCoreArg args      `thenTM` \ args' ->
 501     returnTM (Con con args')
 502
 503 tidyCoreExpr (Prim prim args)
 504   = mapTM tidyCoreArg args      `thenTM` \ args' ->
 505     returnTM (Prim prim args')
 506
 507 tidyCoreExpr (Lam bndr body)
 508   = tidyCoreExpr body           `thenTM` \ body' ->
 509     returnTM (Lam bndr body')
 510
 511         -- Try for let-to-case (see notes in Simplify.lhs for why
 512         -- some let-to-case stuff is deferred to now).
 513 tidyCoreExpr (Let (NonRec bndr rhs) body)
 514   | willBeDemanded (getIdDemandInfo bndr) &&
 515     typeOkForCase (idType bndr)
 516   = ASSERT( not (isPrimType (idType bndr)) )
 517     tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
 518
 519 tidyCoreExpr (Let bind body)
 520   = tidyCoreBinding bind        `thenTM` \ bind' ->
 521     tidyCoreExprEta body        `thenTM` \ body' ->
 522     returnTM (Let bind' body')
 523
 524 tidyCoreExpr (SCC cc body)
 525   = tidyCoreExprEta body        `thenTM` \ body' ->
 526     returnTM (SCC cc body')
 527
 528 tidyCoreExpr (Coerce coercion ty body)
 529   = tidyCoreExprEta body        `thenTM` \ body' ->
 530     returnTM (Coerce coercion ty body')
 531
 532 -- Wierd case for par, seq, fork etc. See notes above.
 533 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
 534   | funnyParallelOp op
 535   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 536     tidyCoreExprEta rhs                 `thenTM` \ rhs' ->
 537     returnTM (Case scrut' (PrimAlts [] (BindDefault binder rhs')))
 538
 539 -- Eliminate polymorphic case, for which we can't generate code just yet
 540 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
 541   | not (typeOkForCase (idType deflt_bndr))
 542   = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $
 543     case scrut of
 544         Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs)
 545         other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
 546
 547 tidyCoreExpr (Case scrut alts)
 548   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 549     tidy_alts scrut' alts               `thenTM` \ alts' ->
 550     returnTM (Case scrut' alts')
 551   where
 552     tidy_alts scrut (AlgAlts alts deflt)
 553         = mapTM tidy_alg_alt alts       `thenTM` \ alts' ->
 554           tidy_deflt scrut deflt        `thenTM` \ deflt' ->
 555           returnTM (AlgAlts alts' deflt')
 556
 557     tidy_alts scrut (PrimAlts alts deflt)
 558         = mapTM tidy_prim_alt alts      `thenTM` \ alts' ->
 559           tidy_deflt scrut deflt        `thenTM` \ deflt' ->
 560           returnTM (PrimAlts alts' deflt')
 561
 562     tidy_alg_alt (con,bndrs,rhs) = tidyCoreExprEta rhs  `thenTM` \ rhs' ->
 563                                    returnTM (con,bndrs,rhs')
 564
 565     tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs       `thenTM` \ rhs' ->
 566                               returnTM (lit,rhs')
 567
 568         -- We convert   case x of {...; x' -> ...x'...}
 569         --      to
 570         --              case x of {...; _  -> ...x... }
 571         --
 572         -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
 573         -- It's quite easily done: simply extend the environment to bind the
 574         -- default binder to the scrutinee.
 575
 576     tidy_deflt scrut NoDefault = returnTM NoDefault
 577     tidy_deflt scrut (BindDefault bndr rhs)
 578         = extend_env (tidyCoreExprEta rhs)      `thenTM` \ rhs' ->
 579           returnTM (BindDefault bndr rhs')
 580         where
 581           extend_env = case scrut of
 582                             Var v -> extendEnvTM bndr v
 583                             other -> \x -> x
 584
 585 tidyCoreExprEta e = tidyCoreExpr e      `thenTM` \ e' ->
 586                     returnTM (etaCoreExpr e')
 587 \end{code}
 588
 589 Arguments
 590 ~~~~~~~~~
 591 \begin{code}
 592 tidyCoreArg :: CoreArg -> TidyM CoreArg
 593
 594 tidyCoreArg (VarArg v)
 595   = lookupTM v  `thenTM` \ v' ->
 596     returnTM (VarArg v')
 597
 598 tidyCoreArg (LitArg lit)
 599   = litToRep lit                `thenTM` \ (lit_ty, lit_expr) ->
 600     case lit_expr of
 601         Var v -> returnTM (VarArg v)
 602         Lit l -> returnTM (LitArg l)
 603         other -> addTopFloat lit_ty lit_expr    `thenTM` \ v ->
 604                  returnTM (VarArg v)
 605
 606 tidyCoreArg (TyArg ty)   = returnTM (TyArg ty)
 607 tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
 608 \end{code}
 609
 610
 611 %************************************************************************
 612 %*                                                                      *
 613 \subsection[coreToStg-lits]{Converting literals}
 614 %*                                                                      *
 615 %************************************************************************
 616
 617 Literals: the NoRep kind need to be de-no-rep'd.
 618 We always replace them with a simple variable, and float a suitable
 619 binding out to the top level.
 620
 621 \begin{code}
 622
 623 litToRep :: Literal -> TidyM (Type, CoreExpr)
 624
 625 litToRep (NoRepStr s)
 626   = returnTM (stringTy, rhs)
 627   where
 628     rhs = if (any is_NUL (_UNPK_ s))
 629
 630           then   -- Must cater for NULs in literal string
 631                 mkGenApp (Var unpackCString2Id)
 632                          [LitArg (MachStr s),
 633                           LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
 634
 635           else  -- No NULs in the string
 636                 App (Var unpackCStringId) (LitArg (MachStr s))
 637
 638     is_NUL c = c == '\0'
 639 \end{code}
 640
 641 If an Integer is small enough (Haskell implementations must support
 642 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 643 otherwise, wrap with @litString2Integer@.
 644
 645 \begin{code}
 646 litToRep (NoRepInteger i integer_ty)
 647   = returnTM (integer_ty, rhs)
 648   where
 649     rhs | i == 0    = Var integerZeroId   -- Extremely convenient to look out for
 650         | i == 1    = Var integerPlusOneId  -- a few very common Integer literals!
 651         | i == 2    = Var integerPlusTwoId
 652         | i == (-1) = Var integerMinusOneId
 653
 654         | i > tARGET_MIN_INT &&         -- Small enough, so start from an Int
 655           i < tARGET_MAX_INT
 656         = Prim Int2IntegerOp [LitArg (mkMachInt i)]
 657
 658         | otherwise                     -- Big, so start from a string
 659         = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
 660
 661
 662 litToRep (NoRepRational r rational_ty)
 663   = tidyCoreArg (LitArg (NoRepInteger (numerator   r) integer_ty))      `thenTM` \ num_arg ->
 664     tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty))      `thenTM` \ denom_arg ->
 665     returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
 666   where
 667     (ratio_data_con, integer_ty)
 668       = case (maybeAppDataTyCon rational_ty) of
 669           Just (tycon, [i_ty], [con])
 670             -> ASSERT(is_integer_ty i_ty && uniqueOf tycon == ratioTyConKey)
 671                (con, i_ty)
 672
 673           _ -> (panic "ratio_data_con", panic "integer_ty")
 674
 675     is_integer_ty ty
 676       = case (maybeAppDataTyCon ty) of
 677           Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
 678           _                   -> False
 679
 680 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
 681 \end{code}
 682
 683 \begin{code}
 684 funnyParallelOp SeqOp  = True
 685 funnyParallelOp ParOp  = True
 686 funnyParallelOp ForkOp = True
 687 funnyParallelOp _      = False
 688 \end{code}
 689
 690
 691 %************************************************************************
 692 %*                                                                      *
 693 \subsection{The monad}
 694 %*                                                                      *
 695 %************************************************************************
 696
 697 \begin{code}
 698 type TidyM a =  Module
 699              -> IdEnv Id
 700              -> (UniqSupply, Bag CoreBinding)
 701              -> (a, (UniqSupply, Bag CoreBinding))
 702
 703 initTM mod env us m
 704   = case m mod env (us,emptyBag) of
 705         (result, (us',floats)) -> result
 706
 707 returnTM v mod env usf = (v, usf)
 708 thenTM m k mod env usf = case m mod env usf of
 709                            (r, usf') -> k r mod env usf'
 710
 711 mapTM f []     = returnTM []
 712 mapTM f (x:xs) = f x    `thenTM` \ r ->
 713                  mapTM f xs     `thenTM` \ rs ->
 714                  returnTM (r:rs)
 715 \end{code}
 716
 717
 718 \begin{code}
 719 getFloats :: TidyM a -> TidyM (a, Bag CoreBinding)
 720 getFloats m mod env (us,floats)
 721   = case m mod env (us,emptyBag) of
 722         (r, (us',floats')) -> ((r, floats'), (us',floats))
 723
 724
 725 -- Need to extend the environment when we munge a binder, so that occurrences
 726 -- of the binder will print the correct way (i.e. as a global not a local)
 727 mungeTopBinder :: Id -> (Id -> TidyM a) -> TidyM a
 728 mungeTopBinder id thing_inside mod env usf
 729   = case lookupIdEnv env id of
 730         Just global -> thing_inside global mod env usf
 731         Nothing     -> thing_inside new_global mod new_env usf
 732                     where
 733                        new_env    = addOneToIdEnv env id new_global
 734                        new_global = setIdVisibility mod id
 735
 736 mungeTopBinders []     k = k []
 737 mungeTopBinders (b:bs) k = mungeTopBinder b     $ \ b' ->
 738                            mungeTopBinders bs   $ \ bs' ->
 739                            k (b' : bs')
 740
 741 addTopFloat :: Type -> CoreExpr -> TidyM Id
 742 addTopFloat lit_ty lit_rhs mod env (us, floats)
 743   = case splitUniqSupply us of
 744      (us',us1) ->
 745        let
 746         lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc
 747         lit_id = setIdVisibility mod lit_local
 748         --(us', us1) = splitUniqSupply us
 749         uniq = getUnique us1
 750        in
 751        (lit_id, (us', floats `snocBag` NonRec lit_id lit_rhs))
 752 {-
 753   where
 754     lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc
 755     lit_id = setIdVisibility mod lit_local
 756     (us', us1) = splitUniqSupply us
 757     uniq = getUnique us1
 758 -}
 759 lookupTM v mod env usf
 760   = case lookupIdEnv env v of
 761         Nothing -> (v, usf)
 762         Just v' -> (v', usf)
 763
 764 extendEnvTM v v' m mod env usf
 765   = m mod (addOneToIdEnv env v v') usf
 766 \end{code}
 767
 768