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