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