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