2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 #include "HsVersions.h"
9 module SimplCore ( core2core ) where
12 IMPORT_1_3(IO(hPutStr,stderr))
14 import AnalFBWW ( analFBWW )
15 import Bag ( isEmptyBag, foldBag )
16 import BinderInfo ( BinderInfo{-instance Outputable-} )
17 import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
19 opt_D_simplifier_stats,
21 opt_D_verbose_core2core,
24 opt_ReportWhyUnfoldingsDisallowed,
26 opt_LiberateCaseThreshold
28 import CoreLint ( lintCoreBindings )
30 import CoreUtils ( coreExprType )
31 import SimplUtils ( etaCoreExpr, typeOkForCase )
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,
45 GenId{-instance Outputable-}, SYN_IE(Id)
47 import IdInfo ( willBeDemanded, DemandInfo )
48 import Name ( isExported, isLocallyDefined,
49 isLocalName, uniqToOccName,
50 SYN_IE(Module), NamedThing(..), OccName(..)
52 import TyCon ( TyCon )
53 import PrimOp ( PrimOp(..) )
54 import PrelVals ( unpackCStringId, unpackCString2Id,
55 integerZeroId, integerPlusOneId,
56 integerPlusTwoId, integerMinusOneId
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 * (,) -}
66 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-},
69 import Pretty ( Doc, vcat, ($$), hsep )
70 import SAT ( doStaticArgs )
71 import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
72 import SimplPgm ( simplifyPgm )
74 import SpecUtils ( pprSpecErrs )
75 import StrictAnal ( saWwTopBinds )
76 import TyVar ( SYN_IE(TyVar), nullTyVarEnv, GenTyVar{-instance Eq-},
79 import Unique ( Unique{-instance Eq-}, Uniquable(..),
80 integerTyConKey, ratioTyConKey,
84 import UniqSupply ( UniqSupply, mkSplitUniqSupply,
85 splitUniqSupply, getUnique
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 )
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...
105 ([CoreBinding], -- results: program, plus...
106 SpecialiseData) -- specialisation data
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)
113 >>= \ (processed_binds, us', spec_data, simpl_stats) ->
115 -- Do the final tidy-up
117 final_binds = tidyCorePgm module_name processed_binds
119 lintCoreBindings "TidyCorePgm" True final_binds >>
123 dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core)
124 "Core transformations"
125 (pprCoreBindings pprDumpStyle final_binds) >>
128 doIfSet opt_D_simplifier_stats
129 (hPutStr stderr ("\nSimplifier Stats:\n") >>
130 hPutStr stderr (showSimplCount simpl_stats) >>
131 hPutStr stderr "\n") >>
134 return (final_binds, spec_data)
136 init_specdata = initSpecData local_tycons tycon_specs
139 do_core_pass info@(binds, us, spec_data, simpl_stats) to_do =
140 case (splitUniqSupply us) 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 "")
154 CoreDoFoldrBuildWorkerWrapper
155 -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
157 case (mkFoldrBuildWW us1 binds) of { binds2 ->
158 end_pass us2 binds2 spec_data simpl_stats "FBWW" }
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" }
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" }
173 -> _scc_ "FloatInwards"
174 begin_pass "FloatIn" >>
175 case (floatInwards binds) of { binds2 ->
176 end_pass us2 binds2 spec_data simpl_stats "FloatIn" }
179 -> _scc_ "CoreFloating"
180 begin_pass "FloatOut" >>
181 case (floatOutwards us1 binds) of { binds2 ->
182 end_pass us2 binds2 spec_data simpl_stats "FloatOut" }
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])
194 -> _scc_ "CoreStranal"
195 begin_pass "StrAnal" >>
196 case (saWwTopBinds us1 binds) of { binds2 ->
197 end_pass us2 binds2 spec_data simpl_stats "StrAnal" }
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)) ->
206 -- if we got errors, we die straight away
207 doIfSet ((not spec_noerrs) ||
208 (opt_ShowImportSpecs && not (isEmptyBag spec_warn)))
210 (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
213 doIfSet (not spec_noerrs) -- Stop here if specialisation errors occured
216 end_pass us2 p spec_data2 simpl_stats "Specialise"
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)
224 -------------------------------------------------
227 = if opt_D_show_passes
228 then hPutStr stderr ("*** Core2Core: "++what++"\n")
232 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
234 = -- Report verbosely, if required
235 dumpIfSet opt_D_verbose_core2core what
236 (pprCoreBindings pprDumpStyle binds2) >>
238 lintCoreBindings what spec_done binds2 >>
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
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 ->
256 %************************************************************************
258 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
260 %************************************************************************
262 Several tasks are done by @tidyCorePgm@
264 1. Eliminate indirections. The point here is to transform
270 2. Make certain top-level bindings into Globals. The point is that
271 Global things get externally-visible labels at code generation
274 3. Make the representation of NoRep literals explicit, and
275 float their bindings to the top level
278 case x of {...; x' -> ...x'...}
280 case x of {...; _ -> ...x... }
281 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
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:
297 6. Eliminate polymorphic case expressions. We can't generate code for them yet.
299 7. Do eta reduction for lambda abstractions appearing in:
300 - the RHS of case alternatives
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.)
306 8. Do let-to-case. See notes in Simplify.lhs for why we defer let-to-case
307 for multi-constructor types.
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.]
315 Eliminate indirections
316 ~~~~~~~~~~~~~~~~~~~~~~
317 In @elimIndirections@, we look for things at the top-level of the form...
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.
327 We rely on prior eta reduction to simplify things like
329 x_exported = /\ tyvars -> x_local tyvars
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:
338 x_exported1 = x_local
339 x_exported2 = x_local
343 x_exported2 = x_exported1
346 There's a possibility of leaving unchanged something like this:
349 x_exported1 = x_local Int
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.
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.
363 tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
365 tidyCorePgm mod binds_in
366 = initTM mod indirection_env $
367 tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds ->
368 returnTM (bagToList binds)
370 (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
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
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!
381 not (isExported rhs_id) && -- Only if this one is not itself exported,
382 -- since the transformation will nuke it
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
392 -- Here, we'll make a local, non-exported, defn for MkT, and without the
393 -- above condition we'll transform it to:
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.
401 not (maybeToBool (lookupIdEnv env_so_far rhs_id))
402 -- Only if not already substituted for
404 = (addOneToIdEnv env_so_far rhs_id (ValBinder new_rhs_id), Nothing)
406 maybe_rhs_id = case etaCoreExpr rhs of
407 Var rhs_id -> Just rhs_id
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.
417 try_bind env_so_far bind
418 = (env_so_far, Just bind)
424 tidyTopBindings [] = returnTM emptyBag
425 tidyTopBindings (b:bs)
429 tidyTopBinding :: CoreBinding
430 -> TopTidyM (Bag CoreBinding)
431 -> TopTidyM (Bag CoreBinding)
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)
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)
445 (binders, rhss) = unzip pairs
453 tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
456 tidyCoreExpr (Lit lit)
457 = litToRep lit `thenTM` \ (_, lit_expr) ->
460 tidyCoreExpr (App fun arg)
461 = tidyCoreExpr fun `thenTM` \ fun' ->
462 tidyCoreArg arg `thenTM` \ arg' ->
463 returnTM (App fun' arg')
465 tidyCoreExpr (Con con args)
466 = mapTM tidyCoreArg args `thenTM` \ args' ->
467 returnTM (Con con args')
469 tidyCoreExpr (Prim prim args)
470 = tidyPrimOp prim `thenTM` \ prim' ->
471 mapTM tidyCoreArg args `thenTM` \ args' ->
472 returnTM (Prim prim' args')
474 tidyCoreExpr (Lam (ValBinder v) body)
476 tidyCoreExpr body `thenTM` \ body' ->
477 returnTM (Lam (ValBinder v') body')
479 tidyCoreExpr (Lam (TyBinder tv) body)
480 = newTyVar tv $ \ tv' ->
481 tidyCoreExpr body `thenTM` \ body' ->
482 returnTM (Lam (TyBinder tv') body')
484 tidyCoreExpr (Lam (UsageBinder uv) body)
485 = newUVar uv $ \ uv' ->
486 tidyCoreExpr body `thenTM` \ body' ->
487 returnTM (Lam (UsageBinder uv') body')
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)))
498 rhs_is_whnf = case mkFormSummary rhs of
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')
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')
515 (bndrs, rhss) = unzip pairs
517 tidyCoreExpr (SCC cc body)
518 = tidyCoreExprEta body `thenTM` \ body' ->
519 returnTM (SCC cc body')
521 tidyCoreExpr (Coerce coercion ty body)
522 = tidyCoreExprEta body `thenTM` \ body' ->
523 tidyTy ty `thenTM` \ ty' ->
524 returnTM (Coerce coercion ty' body')
526 -- Wierd case for par, seq, fork etc. See notes above.
527 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
529 = tidyCoreExpr scrut `thenTM` \ scrut' ->
530 newId binder $ \ binder' ->
531 tidyCoreExprEta rhs `thenTM` \ rhs' ->
532 returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
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) $
539 Var v -> lookupId v `thenTM` \ v' ->
540 extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
541 other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
543 tidyCoreExpr (Case scrut alts)
544 = tidyCoreExpr scrut `thenTM` \ scrut' ->
545 tidy_alts scrut' alts `thenTM` \ alts' ->
546 returnTM (Case scrut' alts')
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')
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')
558 tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
559 tidyCoreExprEta rhs `thenTM` \ rhs' ->
560 returnTM (con, bndrs', rhs')
562 tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
565 -- We convert case x of {...; x' -> ...x'...}
567 -- case x of {...; _ -> ...x... }
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.
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')
579 extend_env = case scrut of
580 Var v -> extendEnvTM bndr v
583 tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
584 returnTM (etaCoreExpr e')
590 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
592 tidyCoreArg (VarArg v)
593 = lookupId v `thenTM` \ v' ->
596 tidyCoreArg (LitArg lit)
597 = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
599 Var v -> returnTM (VarArg v)
600 Lit l -> returnTM (LitArg l)
601 other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
604 tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
606 tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
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')
615 tidyPrimOp other_prim_op = returnTM other_prim_op
619 %************************************************************************
621 \subsection[coreToStg-lits]{Converting literals}
623 %************************************************************************
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.
631 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
633 litToRep (NoRepStr s)
634 = returnTM (stringTy, rhs)
636 rhs = if (any is_NUL (_UNPK_ s))
638 then -- Must cater for NULs in literal string
639 mkGenApp (Var unpackCString2Id)
641 LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
643 else -- No NULs in the string
644 App (Var unpackCStringId) (LitArg (MachStr s))
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@.
654 litToRep (NoRepInteger i integer_ty)
655 = returnTM (integer_ty, rhs)
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
662 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
664 = Prim Int2IntegerOp [LitArg (mkMachInt i)]
666 | otherwise -- Big, so start from a string
667 = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
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])
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)
681 _ -> (panic "ratio_data_con", panic "integer_ty")
683 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
687 funnyParallelOp SeqOp = True
688 funnyParallelOp ParOp = True
689 funnyParallelOp ForkOp = True
690 funnyParallelOp _ = False
694 %************************************************************************
696 \subsection{The monad}
698 %************************************************************************
701 type TidyM a state = Module
702 -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
706 type TopTidyM a = TidyM a Unique
707 type NestTidyM a = TidyM a (Unique, -- Global names
708 Unique, -- Local names
709 Bag CoreBinding) -- Floats
712 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
714 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
716 = case m mod env initialTopTidyUnique of
717 (result, _) -> result
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')
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'
728 mapTM f [] = returnTM []
729 mapTM f (x:xs) = f x `thenTM` \ r ->
730 mapTM f xs `thenTM` \ rs ->
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
743 other -> -- Give it a new print-name unless it's an exported thing
744 -- setNameVisibility also does the local/global thing
746 (id', us') | isExported id = (id, us)
748 = (setIdVisibility (Just mod) us id,
751 new_env = addToUFM env id (ValBinder id')
753 thing_inside id' mod new_env us'
755 mungeTopBinders [] k = k []
756 mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
757 mungeTopBinders bs $ \ bs' ->
760 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
761 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
763 gus' = incrUnique gus
764 lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
765 lit_id = setIdVisibility (Just mod) gus lit_local
767 (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
769 lookupId :: Id -> TidyM Id state
770 lookupId v mod env usf
771 = case lookupUFM env v of
773 Just (ValBinder v') -> (v', usf)
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
781 Making new local binders
782 ~~~~~~~~~~~~~~~~~~~~~~~~
784 newId id thing_inside mod env (gus, local_uniq, floats)
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')
792 thing_inside id' mod env' (gus, local_uniq', floats)
794 newIds [] thing_inside
796 newIds (bndr:bndrs) thing_inside
797 = newId bndr $ \ bndr' ->
798 newIds bndrs $ \ bndrs' ->
799 thing_inside (bndr' : bndrs')
802 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
804 local_uniq' = incrUnique local_uniq
805 tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
806 env' = addToUFM env tyvar (TyBinder tyvar')
808 thing_inside tyvar' mod env' (gus, local_uniq', floats)
810 newUVar uvar thing_inside mod env (gus, local_uniq, floats)
812 local_uniq' = incrUnique local_uniq
813 uvar' = cloneUVar uvar local_uniq
814 env' = addToUFM env uvar (UsageBinder uvar')
816 thing_inside uvar' mod env' (gus, local_uniq', floats)
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.
827 -- This little impedance-matcher calls nmbrType with the right arguments
829 = nmbrType tv_env u_env uniq ty
831 tv_env :: TyVar -> TyVar
832 tv_env tyvar = case lookupUFM env tyvar of
833 Just (TyBinder tyvar') -> tyvar'
836 u_env :: UVar -> UVar
837 u_env uvar = case lookupUFM env uvar of
838 Just (UsageBinder uvar') -> uvar'