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