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