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 )
  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   = mapTM tidyCoreArg args      `thenTM` \ args' ->
 505     returnTM (Prim prim args')
 506
 507 tidyCoreExpr (Lam (ValBinder v) body)
 508   = newId v                     $ \ v' ->
 509     tidyCoreExpr body           `thenTM` \ body' ->
 510     returnTM (Lam (ValBinder v') body')
 511
 512 tidyCoreExpr (Lam (TyBinder tv) body)
 513   = newTyVar tv                 $ \ tv' ->
 514     tidyCoreExpr body           `thenTM` \ body' ->
 515     returnTM (Lam (TyBinder tv') body')
 516
 517 tidyCoreExpr (Lam (UsageBinder uv) body)
 518   = newUVar uv                  $ \ uv' ->
 519     tidyCoreExpr body           `thenTM` \ body' ->
 520     returnTM (Lam (UsageBinder uv') body')
 521
 522         -- Try for let-to-case (see notes in Simplify.lhs for why
 523         -- some let-to-case stuff is deferred to now).
 524 tidyCoreExpr (Let (NonRec bndr rhs) body)
 525   | willBeDemanded (getIdDemandInfo bndr) &&
 526     typeOkForCase (idType bndr)
 527   = ASSERT( not (isPrimType (idType bndr)) )
 528     tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
 529
 530 tidyCoreExpr (Let (NonRec bndr rhs) body)
 531   = tidyCoreExpr rhs            `thenTM` \ rhs' ->
 532     newId bndr                  $ \ bndr' ->
 533     tidyCoreExprEta body        `thenTM` \ body' ->
 534     returnTM (Let (NonRec bndr' rhs') body')
 535
 536 tidyCoreExpr (Let (Rec pairs) body)
 537   = newIds bndrs                $ \ bndrs' ->
 538     mapTM tidyCoreExpr rhss     `thenTM` \ rhss' ->
 539     tidyCoreExprEta body        `thenTM` \ body' ->
 540     returnTM (Let (Rec (bndrs' `zip` rhss')) body')
 541   where
 542     (bndrs, rhss) = unzip pairs
 543
 544 tidyCoreExpr (SCC cc body)
 545   = tidyCoreExprEta body        `thenTM` \ body' ->
 546     returnTM (SCC cc body')
 547
 548 tidyCoreExpr (Coerce coercion ty body)
 549   = tidyCoreExprEta body        `thenTM` \ body' ->
 550     tidyTy ty                   `thenTM` \ ty' ->
 551     returnTM (Coerce coercion ty' body')
 552
 553 -- Wierd case for par, seq, fork etc. See notes above.
 554 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
 555   | funnyParallelOp op
 556   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 557     newId binder                        $ \ binder' ->
 558     tidyCoreExprEta rhs                 `thenTM` \ rhs' ->
 559     returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
 560
 561 -- Eliminate polymorphic case, for which we can't generate code just yet
 562 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
 563   | not (typeOkForCase (idType deflt_bndr))
 564   = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $
 565     case scrut of
 566         Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs)
 567         other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
 568
 569 tidyCoreExpr (Case scrut alts)
 570   = tidyCoreExpr scrut                  `thenTM` \ scrut' ->
 571     tidy_alts scrut' alts               `thenTM` \ alts' ->
 572     returnTM (Case scrut' alts')
 573   where
 574     tidy_alts scrut (AlgAlts alts deflt)
 575         = mapTM tidy_alg_alt alts       `thenTM` \ alts' ->
 576           tidy_deflt scrut deflt        `thenTM` \ deflt' ->
 577           returnTM (AlgAlts alts' deflt')
 578
 579     tidy_alts scrut (PrimAlts alts deflt)
 580         = mapTM tidy_prim_alt alts      `thenTM` \ alts' ->
 581           tidy_deflt scrut deflt        `thenTM` \ deflt' ->
 582           returnTM (PrimAlts alts' deflt')
 583
 584     tidy_alg_alt (con,bndrs,rhs) = newIds bndrs         $ \ bndrs' ->
 585                                    tidyCoreExprEta rhs  `thenTM` \ rhs' ->
 586                                    returnTM (con, bndrs', rhs')
 587
 588     tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs       `thenTM` \ rhs' ->
 589                               returnTM (lit,rhs')
 590
 591         -- We convert   case x of {...; x' -> ...x'...}
 592         --      to
 593         --              case x of {...; _  -> ...x... }
 594         --
 595         -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
 596         -- It's quite easily done: simply extend the environment to bind the
 597         -- default binder to the scrutinee.
 598
 599     tidy_deflt scrut NoDefault = returnTM NoDefault
 600     tidy_deflt scrut (BindDefault bndr rhs)
 601         = newId bndr                            $ \ bndr' ->
 602           extend_env (tidyCoreExprEta rhs)      `thenTM` \ rhs' ->
 603           returnTM (BindDefault bndr' rhs')
 604         where
 605           extend_env = case scrut of
 606                             Var v -> extendEnvTM bndr v
 607                             other -> \x -> x
 608
 609 tidyCoreExprEta e = tidyCoreExpr e      `thenTM` \ e' ->
 610                     returnTM (etaCoreExpr e')
 611 \end{code}
 612
 613 Arguments
 614 ~~~~~~~~~
 615 \begin{code}
 616 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
 617
 618 tidyCoreArg (VarArg v)
 619   = lookupId v  `thenTM` \ v' ->
 620     returnTM (VarArg v')
 621
 622 tidyCoreArg (LitArg lit)
 623   = litToRep lit                `thenTM` \ (lit_ty, lit_expr) ->
 624     case lit_expr of
 625         Var v -> returnTM (VarArg v)
 626         Lit l -> returnTM (LitArg l)
 627         other -> addTopFloat lit_ty lit_expr    `thenTM` \ v ->
 628                  returnTM (VarArg v)
 629
 630 tidyCoreArg (TyArg ty)   = tidyTy ty    `thenTM` \ ty' ->
 631                            returnTM (TyArg ty')
 632 tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
 633 \end{code}
 634
 635
 636 %************************************************************************
 637 %*                                                                      *
 638 \subsection[coreToStg-lits]{Converting literals}
 639 %*                                                                      *
 640 %************************************************************************
 641
 642 Literals: the NoRep kind need to be de-no-rep'd.
 643 We always replace them with a simple variable, and float a suitable
 644 binding out to the top level.
 645
 646 \begin{code}
 647
 648 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
 649
 650 litToRep (NoRepStr s)
 651   = returnTM (stringTy, rhs)
 652   where
 653     rhs = if (any is_NUL (_UNPK_ s))
 654
 655           then   -- Must cater for NULs in literal string
 656                 mkGenApp (Var unpackCString2Id)
 657                          [LitArg (MachStr s),
 658                           LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
 659
 660           else  -- No NULs in the string
 661                 App (Var unpackCStringId) (LitArg (MachStr s))
 662
 663     is_NUL c = c == '\0'
 664 \end{code}
 665
 666 If an Integer is small enough (Haskell implementations must support
 667 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
 668 otherwise, wrap with @litString2Integer@.
 669
 670 \begin{code}
 671 litToRep (NoRepInteger i integer_ty)
 672   = returnTM (integer_ty, rhs)
 673   where
 674     rhs | i == 0    = Var integerZeroId   -- Extremely convenient to look out for
 675         | i == 1    = Var integerPlusOneId  -- a few very common Integer literals!
 676         | i == 2    = Var integerPlusTwoId
 677         | i == (-1) = Var integerMinusOneId
 678
 679         | i > tARGET_MIN_INT &&         -- Small enough, so start from an Int
 680           i < tARGET_MAX_INT
 681         = Prim Int2IntegerOp [LitArg (mkMachInt i)]
 682
 683         | otherwise                     -- Big, so start from a string
 684         = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
 685
 686
 687 litToRep (NoRepRational r rational_ty)
 688   = tidyCoreArg (LitArg (NoRepInteger (numerator   r) integer_ty))      `thenTM` \ num_arg ->
 689     tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty))      `thenTM` \ denom_arg ->
 690     returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
 691   where
 692     (ratio_data_con, integer_ty)
 693       = case (maybeAppDataTyCon rational_ty) of
 694           Just (tycon, [i_ty], [con])
 695             -> ASSERT(is_integer_ty i_ty && uniqueOf tycon == ratioTyConKey)
 696                (con, i_ty)
 697
 698           _ -> (panic "ratio_data_con", panic "integer_ty")
 699
 700     is_integer_ty ty
 701       = case (maybeAppDataTyCon ty) of
 702           Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
 703           _                   -> False
 704
 705 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
 706 \end{code}
 707
 708 \begin{code}
 709 funnyParallelOp SeqOp  = True
 710 funnyParallelOp ParOp  = True
 711 funnyParallelOp ForkOp = True
 712 funnyParallelOp _      = False
 713 \end{code}
 714
 715
 716 %************************************************************************
 717 %*                                                                      *
 718 \subsection{The monad}
 719 %*                                                                      *
 720 %************************************************************************
 721
 722 \begin{code}
 723 type TidyM a state =  Module
 724                       -> UniqFM CoreBinder              -- Maps Ids to Ids, TyVars to TyVars etc
 725                       -> state
 726                       -> (a, state)
 727
 728 type TopTidyM  a = TidyM a Unique
 729 type NestTidyM a = TidyM a (Unique,                     -- Global names
 730                             Unique,                     -- Local names
 731                             Bag CoreBinding)            -- Floats
 732
 733
 734 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
 735
 736 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
 737 initTM mod env m
 738   = case m mod env initialTopTidyUnique of
 739         (result, _) -> result
 740
 741 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
 742 initNestedTM m mod env global_us
 743   = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
 744         (result, (global_us', _, floats)) -> ((result, floats), global_us')
 745
 746 returnTM v mod env usf = (v, usf)
 747 thenTM m k mod env usf = case m mod env usf of
 748                            (r, usf') -> k r mod env usf'
 749
 750 mapTM f []     = returnTM []
 751 mapTM f (x:xs) = f x    `thenTM` \ r ->
 752                  mapTM f xs     `thenTM` \ rs ->
 753                  returnTM (r:rs)
 754 \end{code}
 755
 756
 757 \begin{code}
 758 -- Need to extend the environment when we munge a binder, so that occurrences
 759 -- of the binder will print the correct way (i.e. as a global not a local)
 760 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
 761 mungeTopBinder id thing_inside mod env us
 762   = case lookupIdEnv env id of
 763         Just (ValBinder global) -> thing_inside global mod env us       -- Already bound
 764
 765         other ->        -- Give it a new print-name unless it's an exported thing
 766                         -- setNameVisibility also does the local/global thing
 767                  let
 768                         (id', us')  | isExported id = (id, us)
 769                                     | otherwise
 770                                     = (setIdVisibility (Just mod) us id,
 771                                        incrUnique us)
 772
 773                         new_env    = addToUFM env id (ValBinder id')
 774                  in
 775                  thing_inside id' mod new_env us'
 776
 777 mungeTopBinders []     k = k []
 778 mungeTopBinders (b:bs) k = mungeTopBinder b     $ \ b' ->
 779                            mungeTopBinders bs   $ \ bs' ->
 780                            k (b' : bs')
 781
 782 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
 783 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
 784   = let
 785         gus'      = incrUnique gus
 786         lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
 787         lit_id    = setIdVisibility (Just mod) gus lit_local
 788     in
 789     (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
 790
 791 lookupId :: Id -> TidyM Id state
 792 lookupId v mod env usf
 793   = case lookupUFM env v of
 794         Nothing             -> (v, usf)
 795         Just (ValBinder v') -> (v', usf)
 796
 797 extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
 798 extendEnvTM v v' m mod env usf
 799   = m mod (addOneToIdEnv env v (ValBinder v')) usf
 800 \end{code}
 801
 802
 803 Making new local binders
 804 ~~~~~~~~~~~~~~~~~~~~~~~~
 805 \begin{code}
 806 newId id thing_inside mod env (gus, local_uniq, floats)
 807   = let
 808         -- Give the Id a fresh print-name, *and* rename its type
 809         local_uniq'  = incrUnique local_uniq
 810         rn_id        = setIdVisibility Nothing local_uniq id
 811         id'          = apply_to_Id (nmbr_ty env local_uniq') rn_id
 812         env'         = addToUFM env id (ValBinder id')
 813     in
 814     thing_inside id' mod env' (gus, local_uniq', floats)
 815
 816 newIds [] thing_inside
 817   = thing_inside []
 818 newIds (bndr:bndrs) thing_inside
 819   = newId bndr          $ \ bndr' ->
 820     newIds bndrs        $ \ bndrs' ->
 821     thing_inside (bndr' : bndrs')
 822
 823
 824 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
 825   = let
 826         local_uniq' = incrUnique local_uniq
 827         tyvar'      = nameTyVar tyvar (uniqToOccName local_uniq)
 828         env'        = addToUFM env tyvar (TyBinder tyvar')
 829     in
 830     thing_inside tyvar' mod env' (gus, local_uniq', floats)
 831
 832 newUVar uvar thing_inside mod env (gus, local_uniq, floats)
 833   = let
 834         local_uniq' = incrUnique local_uniq
 835         uvar'       = cloneUVar uvar local_uniq
 836         env'        = addToUFM env uvar (UsageBinder uvar')
 837     in
 838     thing_inside uvar' mod env' (gus, local_uniq', floats)
 839 \end{code}
 840
 841 Re-numbering types
 842 ~~~~~~~~~~~~~~~~~~
 843 \begin{code}
 844 tidyTy ty mod env usf@(_, local_uniq, _)
 845   = (nmbr_ty env local_uniq ty, usf)
 846         -- We can use local_uniq as a base for renaming forall'd variables
 847         -- in the type; we don't need to know how many are consumed.
 848
 849 -- This little impedance-matcher calls nmbrType with the right arguments
 850 nmbr_ty env uniq ty
 851   = nmbrType tv_env u_env uniq ty
 852   where
 853     tv_env :: TyVar -> TyVar
 854     tv_env tyvar = case lookupUFM env tyvar of
 855                         Just (TyBinder tyvar') -> tyvar'
 856                         other                  -> tyvar
 857
 858     u_env :: UVar -> UVar
 859     u_env uvar = case lookupUFM env uvar of
 860                         Just (UsageBinder uvar') -> uvar'
 861                         other                    -> uvar
 862 \end{code}
 863
 864