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