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