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