2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 module SimplCore ( core2core ) where
9 #include "HsVersions.h"
11 import AnalFBWW ( analFBWW )
12 import Bag ( isEmptyBag, foldBag )
13 import BinderInfo ( BinderInfo{-instance Outputable-} )
14 import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
16 opt_D_simplifier_stats,
18 opt_D_verbose_core2core,
21 opt_ReportWhyUnfoldingsDisallowed,
23 opt_LiberateCaseThreshold
25 import CoreLint ( lintCoreBindings )
27 import CoreUtils ( coreExprType )
28 import SimplUtils ( etaCoreExpr, typeOkForCase )
30 import Literal ( Literal(..), literalType, mkMachInt )
31 import ErrUtils ( ghcExit, dumpIfSet, doIfSet )
32 import FiniteMap ( FiniteMap, emptyFM )
33 import FloatIn ( floatInwards )
34 import FloatOut ( floatOutwards )
35 import FoldrBuildWW ( mkFoldrBuildWW )
36 import Id ( mkSysLocal, mkUserId, setIdVisibility, replaceIdInfo,
37 replacePragmaInfo, getIdDemandInfo, idType,
38 getIdInfo, getPragmaInfo, mkIdWithNewUniq,
39 nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
40 lookupIdEnv, IdEnv, omitIfaceSigForId,
43 import IdInfo ( willBeDemanded, DemandInfo )
44 import Name ( isExported, isLocallyDefined,
45 isLocalName, uniqToOccName,
47 Module, NamedThing(..), OccName(..)
49 import TyCon ( TyCon )
50 import PrimOp ( PrimOp(..) )
51 import PrelVals ( unpackCStringId, unpackCString2Id,
52 integerZeroId, integerPlusOneId,
53 integerPlusTwoId, integerMinusOneId
55 import Type ( splitAlgTyConApp_maybe, isUnpointedType, Type )
56 import TysWiredIn ( stringTy, isIntegerTy )
57 import LiberateCase ( liberateCase )
58 import MagicUFs ( MagicUnfoldingFun )
60 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-},
63 import SAT ( doStaticArgs )
64 import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
65 import SimplPgm ( simplifyPgm )
67 import SpecUtils ( pprSpecErrs )
68 import StrictAnal ( saWwTopBinds )
69 import TyVar ( TyVar, nameTyVar )
70 import Unique ( Unique{-instance Eq-}, Uniquable(..),
71 integerTyConKey, ratioTyConKey,
75 import UniqSupply ( UniqSupply, mkSplitUniqSupply,
76 splitUniqSupply, getUnique
78 import UniqFM ( UniqFM, lookupUFM, addToUFM )
79 import Util ( mapAccumL )
80 import SrcLoc ( noSrcLoc )
81 import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
84 import IO ( hPutStr, stderr )
89 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
90 -> FAST_STRING -- module name (profiling only)
91 -> UniqSupply -- a name supply
92 -> [TyCon] -- local data tycons and tycon specialisations
93 -> [CoreBinding] -- input...
94 -> IO [CoreBinding] -- results: program
96 core2core core_todos module_name us local_tycons binds
97 = -- Do the main business
99 (binds, us, zeroSimplCount)
101 >>= \ (processed_binds, us', simpl_stats) ->
103 -- Do the final tidy-up
105 final_binds = tidyCorePgm module_name processed_binds
107 lintCoreBindings "TidyCorePgm" True final_binds >>
111 dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core)
112 "Core transformations"
113 (pprCoreBindings final_binds) >>
116 doIfSet opt_D_simplifier_stats
117 (hPutStr stderr ("\nSimplifier Stats:\n") >>
118 hPutStr stderr (showSimplCount simpl_stats) >>
119 hPutStr stderr "\n") >>
125 do_core_pass info@(binds, us, simpl_stats) to_do =
126 case (splitUniqSupply us) of
129 CoreDoSimplify simpl_sw_chkr
130 -> _scc_ "CoreSimplify"
131 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
132 then " (foldr/build)" else "") >>
133 case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
134 (p, it_cnt, simpl_stats2)
135 -> end_pass us2 p simpl_stats2
136 ("Simplify (" ++ show it_cnt ++ ")"
137 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
138 then " foldr/build" else "")
140 CoreDoFoldrBuildWorkerWrapper
141 -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
143 case (mkFoldrBuildWW us1 binds) of { binds2 ->
144 end_pass us2 binds2 simpl_stats "FBWW" }
146 CoreDoFoldrBuildWWAnal
147 -> _scc_ "CoreDoFoldrBuildWWAnal"
148 begin_pass "AnalFBWW" >>
149 case (analFBWW binds) of { binds2 ->
150 end_pass us2 binds2 simpl_stats "AnalFBWW" }
153 -> _scc_ "LiberateCase"
154 begin_pass "LiberateCase" >>
155 case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
156 end_pass us2 binds2 simpl_stats "LiberateCase" }
159 -> _scc_ "FloatInwards"
160 begin_pass "FloatIn" >>
161 case (floatInwards binds) of { binds2 ->
162 end_pass us2 binds2 simpl_stats "FloatIn" }
165 -> _scc_ "CoreFloating"
166 begin_pass "FloatOut" >>
167 case (floatOutwards us1 binds) of { binds2 ->
168 end_pass us2 binds2 simpl_stats "FloatOut" }
171 -> _scc_ "CoreStaticArgs"
172 begin_pass "StaticArgs" >>
173 case (doStaticArgs binds us1) of { binds2 ->
174 end_pass us2 binds2 simpl_stats "StaticArgs" }
175 -- Binds really should be dependency-analysed for static-
176 -- arg transformation... Not to worry, they probably are.
177 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
180 -> _scc_ "CoreStranal"
181 begin_pass "StrAnal" >>
182 case (saWwTopBinds us1 binds) of { binds2 ->
183 end_pass us2 binds2 simpl_stats "StrAnal" }
186 -> _scc_ "Specialise"
187 begin_pass "Specialise" >>
188 case (specProgram us1 binds) of { p ->
189 end_pass us2 p simpl_stats "Specialise"
192 CoreDoPrintCore -- print result of last pass
193 -> dumpIfSet (not opt_D_verbose_core2core) "Print Core"
194 (pprCoreBindings binds) >>
195 return (binds, us1, simpl_stats)
197 -------------------------------------------------
200 = if opt_D_show_passes
201 then hPutStr stderr ("*** Core2Core: "++what++"\n")
206 = -- Report verbosely, if required
207 dumpIfSet opt_D_verbose_core2core what
208 (pprCoreBindings binds2) >>
210 lintCoreBindings what True {- spec_done -} binds2 >>
211 -- The spec_done flag tells the linter to
212 -- complain about unboxed let-bindings
213 -- But we're not specialising unboxed types any more,
214 -- so its irrelevant.
217 (binds2, -- processed binds, possibly run thru CoreLint
218 us2, -- UniqSupply for the next guy
219 simpl_stats2 -- accumulated simplifier stats
223 -- here so it can be inlined...
224 foldl_mn f z [] = return z
225 foldl_mn f z (x:xs) = f z x >>= \ zz ->
231 %************************************************************************
233 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
235 %************************************************************************
237 Several tasks are done by @tidyCorePgm@
239 1. Eliminate indirections. The point here is to transform
245 2. Make certain top-level bindings into Globals. The point is that
246 Global things get externally-visible labels at code generation
249 3. Make the representation of NoRep literals explicit, and
250 float their bindings to the top level
253 case x of {...; x' -> ...x'...}
255 case x of {...; _ -> ...x... }
256 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
258 5. *Mangle* cases involving fork# and par# in the discriminant. The
259 original templates for these primops (see @PrelVals.lhs@) constructed
260 case expressions with boolean results solely to fool the strictness
261 analyzer, the simplifier, and anyone else who might want to fool with
262 the evaluation order. At this point in the compiler our evaluation
263 order is safe. Therefore, we convert expressions of the form:
272 6. Eliminate polymorphic case expressions. We can't generate code for them yet.
274 7. Do eta reduction for lambda abstractions appearing in:
275 - the RHS of case alternatives
277 These will otherwise turn into local bindings during Core->STG; better to
278 nuke them if possible. (In general the simplifier does eta expansion not
279 eta reduction, up to this point.)
281 8. Do let-to-case. See notes in Simplify.lhs for why we defer let-to-case
282 for multi-constructor types.
284 9. Give all binders a nice print-name. Their uniques aren't changed; rather we give
285 them lexically unique occ-names, so that we can safely print the OccNae only
286 in the interface file. [Bad idea to change the uniques, because the code
287 generator makes global labels from the uniques for local thunks etc.]
290 Eliminate indirections
291 ~~~~~~~~~~~~~~~~~~~~~~
292 In @elimIndirections@, we look for things at the top-level of the form...
297 In cases we find like this, we go {\em backwards} and replace
298 \tr{x_local} with \tr{x_exported}. This save a gratuitous jump
299 (from \tr{x_exported} to \tr{x_local}), and makes strictness
300 information propagate better.
302 We rely on prior eta reduction to simplify things like
304 x_exported = /\ tyvars -> x_local tyvars
309 If more than one exported thing is equal to a local thing (i.e., the
310 local thing really is shared), then we do one only:
313 x_exported1 = x_local
314 x_exported2 = x_local
318 x_exported2 = x_exported1
321 There's a possibility of leaving unchanged something like this:
324 x_exported1 = x_local Int
326 By the time we've thrown away the types in STG land this
327 could be eliminated. But I don't think it's very common
328 and it's dangerous to do this fiddling in STG land
329 because we might elminate a binding that's mentioned in the
330 unfolding for something.
332 General Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
333 Then blast the whole program (LHSs as well as RHSs) with it.
338 tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
340 tidyCorePgm mod binds_in
341 = initTM mod indirection_env $
342 tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds ->
343 returnTM (bagToList binds)
345 (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
347 try_bind :: IdEnv CoreBinder -> CoreBinding -> (IdEnv CoreBinder, Maybe CoreBinding)
348 try_bind env_so_far (NonRec exported_binder rhs)
349 | isExported exported_binder && -- Only if this is exported
350 maybeToBool maybe_rhs_id && -- and the RHS is a simple Id
352 isLocallyDefined rhs_id && -- Only if this one is defined in this
353 -- module, so that we *can* change its
354 -- binding to be the exported thing!
356 not (isExported rhs_id) && -- Only if this one is not itself exported,
357 -- since the transformation will nuke it
359 not (omitIfaceSigForId rhs_id) && -- Don't do the transformation if rhs_id is
360 -- something like a constructor, whose
361 -- definition is implicitly exported and
362 -- which must not vanish.
363 -- To illustrate the preceding check consider
367 -- Here, we'll make a local, non-exported, defn for MkT, and without the
368 -- above condition we'll transform it to:
371 -- This is bad because mkT will get the IdDetails of MkT, and won't
372 -- be exported. Also the code generator won't make a definition for
373 -- the MkT constructor.
374 -- Slightly gruesome, this.
376 not (maybeToBool (lookupIdEnv env_so_far rhs_id))
377 -- Only if not already substituted for
379 = (addOneToIdEnv env_so_far rhs_id (ValBinder new_rhs_id), Nothing)
381 maybe_rhs_id = case etaCoreExpr rhs of
382 Var rhs_id -> Just rhs_id
384 Just rhs_id = maybe_rhs_id
385 new_rhs_id = exported_binder `replaceIdInfo` getIdInfo rhs_id
386 `replacePragmaInfo` getPragmaInfo rhs_id
387 -- NB: we keep the Pragmas and IdInfo for the old rhs_id!
388 -- This is important; it might be marked "no-inline" by
389 -- the occurrence analyser (because it's recursive), and
390 -- we must not lose that information.
392 try_bind env_so_far bind
393 = (env_so_far, Just bind)
399 tidyTopBindings [] = returnTM emptyBag
400 tidyTopBindings (b:bs)
404 tidyTopBinding :: CoreBinding
405 -> TopTidyM (Bag CoreBinding)
406 -> TopTidyM (Bag CoreBinding)
408 tidyTopBinding (NonRec bndr rhs) thing_inside
409 = initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
410 mungeTopBinder bndr $ \ bndr' ->
411 thing_inside `thenTM` \ binds ->
412 returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
414 tidyTopBinding (Rec pairs) thing_inside
415 = mungeTopBinders binders $ \ binders' ->
416 initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
417 thing_inside `thenTM` \ binds_inside ->
418 returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
420 (binders, rhss) = unzip pairs
428 tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
431 tidyCoreExpr (Lit lit)
432 = litToRep lit `thenTM` \ (_, lit_expr) ->
435 tidyCoreExpr (App fun arg)
436 = tidyCoreExpr fun `thenTM` \ fun' ->
437 tidyCoreArg arg `thenTM` \ arg' ->
438 returnTM (App fun' arg')
440 tidyCoreExpr (Con con args)
441 = mapTM tidyCoreArg args `thenTM` \ args' ->
442 returnTM (Con con args')
444 tidyCoreExpr (Prim prim args)
445 = tidyPrimOp prim `thenTM` \ prim' ->
446 mapTM tidyCoreArg args `thenTM` \ args' ->
447 returnTM (Prim prim' args')
449 tidyCoreExpr (Lam (ValBinder v) body)
451 tidyCoreExpr body `thenTM` \ body' ->
452 returnTM (Lam (ValBinder v') body')
454 tidyCoreExpr (Lam (TyBinder tv) body)
455 = newTyVar tv $ \ tv' ->
456 tidyCoreExpr body `thenTM` \ body' ->
457 returnTM (Lam (TyBinder tv') body')
459 -- Try for let-to-case (see notes in Simplify.lhs for why
460 -- some let-to-case stuff is deferred to now).
461 tidyCoreExpr (Let (NonRec bndr rhs) body)
462 | willBeDemanded (getIdDemandInfo bndr) &&
463 not rhs_is_whnf && -- Don't do it if RHS is already in WHNF
464 typeOkForCase (idType bndr)
465 = ASSERT( not (isUnpointedType (idType bndr)) )
466 tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
468 rhs_is_whnf = case mkFormSummary rhs of
473 tidyCoreExpr (Let (NonRec bndr rhs) body)
474 = tidyCoreExpr rhs `thenTM` \ rhs' ->
475 newId bndr $ \ bndr' ->
476 tidyCoreExprEta body `thenTM` \ body' ->
477 returnTM (Let (NonRec bndr' rhs') body')
479 tidyCoreExpr (Let (Rec pairs) body)
480 = newIds bndrs $ \ bndrs' ->
481 mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
482 tidyCoreExprEta body `thenTM` \ body' ->
483 returnTM (Let (Rec (bndrs' `zip` rhss')) body')
485 (bndrs, rhss) = unzip pairs
487 tidyCoreExpr (SCC cc body)
488 = tidyCoreExprEta body `thenTM` \ body' ->
489 returnTM (SCC cc body')
491 tidyCoreExpr (Coerce coercion ty body)
492 = tidyCoreExprEta body `thenTM` \ body' ->
493 tidyTy ty `thenTM` \ ty' ->
494 returnTM (Coerce coercion ty' body')
496 -- Wierd case for par, seq, fork etc. See notes above.
497 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
499 = tidyCoreExpr scrut `thenTM` \ scrut' ->
500 newId binder $ \ binder' ->
501 tidyCoreExprEta rhs `thenTM` \ rhs' ->
502 returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
504 -- Eliminate polymorphic case, for which we can't generate code just yet
505 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
506 | not (typeOkForCase (idType deflt_bndr))
507 = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $
509 Var v -> lookupId v `thenTM` \ v' ->
510 extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
511 other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
513 tidyCoreExpr (Case scrut alts)
514 = tidyCoreExpr scrut `thenTM` \ scrut' ->
515 tidy_alts scrut' alts `thenTM` \ alts' ->
516 returnTM (Case scrut' alts')
518 tidy_alts scrut (AlgAlts alts deflt)
519 = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
520 tidy_deflt scrut deflt `thenTM` \ deflt' ->
521 returnTM (AlgAlts alts' deflt')
523 tidy_alts scrut (PrimAlts alts deflt)
524 = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
525 tidy_deflt scrut deflt `thenTM` \ deflt' ->
526 returnTM (PrimAlts alts' deflt')
528 tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
529 tidyCoreExprEta rhs `thenTM` \ rhs' ->
530 returnTM (con, bndrs', rhs')
532 tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
535 -- We convert case x of {...; x' -> ...x'...}
537 -- case x of {...; _ -> ...x... }
539 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
540 -- It's quite easily done: simply extend the environment to bind the
541 -- default binder to the scrutinee.
543 tidy_deflt scrut NoDefault = returnTM NoDefault
544 tidy_deflt scrut (BindDefault bndr rhs)
545 = newId bndr $ \ bndr' ->
546 extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
547 returnTM (BindDefault bndr' rhs')
549 extend_env = case scrut of
550 Var v -> extendEnvTM bndr v
553 tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
554 returnTM (etaCoreExpr e')
560 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
562 tidyCoreArg (VarArg v)
563 = lookupId v `thenTM` \ v' ->
566 tidyCoreArg (LitArg lit)
567 = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
569 Var v -> returnTM (VarArg v)
570 Lit l -> returnTM (LitArg l)
571 other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
574 tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
579 tidyPrimOp (CCallOp fn casm gc tys ty)
580 = mapTM tidyTy tys `thenTM` \ tys' ->
581 tidyTy ty `thenTM` \ ty' ->
582 returnTM (CCallOp fn casm gc tys' ty')
584 tidyPrimOp other_prim_op = returnTM other_prim_op
588 %************************************************************************
590 \subsection[coreToStg-lits]{Converting literals}
592 %************************************************************************
594 Literals: the NoRep kind need to be de-no-rep'd.
595 We always replace them with a simple variable, and float a suitable
596 binding out to the top level.
600 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
602 litToRep (NoRepStr s)
603 = returnTM (stringTy, rhs)
605 rhs = if (any is_NUL (_UNPK_ s))
607 then -- Must cater for NULs in literal string
608 mkGenApp (Var unpackCString2Id)
610 LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
612 else -- No NULs in the string
613 App (Var unpackCStringId) (LitArg (MachStr s))
618 If an Integer is small enough (Haskell implementations must support
619 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
620 otherwise, wrap with @litString2Integer@.
623 litToRep (NoRepInteger i integer_ty)
624 = returnTM (integer_ty, rhs)
626 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
627 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
628 | i == 2 = Var integerPlusTwoId
629 | i == (-1) = Var integerMinusOneId
631 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
633 = Prim Int2IntegerOp [LitArg (mkMachInt i)]
635 | otherwise -- Big, so start from a string
636 = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
639 litToRep (NoRepRational r rational_ty)
640 = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
641 tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
642 returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
644 (ratio_data_con, integer_ty)
645 = case (splitAlgTyConApp_maybe rational_ty) of
646 Just (tycon, [i_ty], [con])
647 -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey)
650 _ -> (panic "ratio_data_con", panic "integer_ty")
652 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
656 funnyParallelOp SeqOp = True
657 funnyParallelOp ParOp = True
658 funnyParallelOp ForkOp = True
659 funnyParallelOp _ = False
663 %************************************************************************
665 \subsection{The monad}
667 %************************************************************************
670 type TidyM a state = Module
671 -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
675 type TopTidyM a = TidyM a Unique
676 type NestTidyM a = TidyM a (Unique, -- Global names
677 Unique, -- Local names
678 Bag CoreBinding) -- Floats
681 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
683 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
685 = case m mod env initialTopTidyUnique of
686 (result, _) -> result
688 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
689 initNestedTM m mod env global_us
690 = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
691 (result, (global_us', _, floats)) -> ((result, floats), global_us')
693 returnTM v mod env usf = (v, usf)
694 thenTM m k mod env usf = case m mod env usf of
695 (r, usf') -> k r mod env usf'
697 mapTM f [] = returnTM []
698 mapTM f (x:xs) = f x `thenTM` \ r ->
699 mapTM f xs `thenTM` \ rs ->
705 -- Need to extend the environment when we munge a binder, so that occurrences
706 -- of the binder will print the correct way (i.e. as a global not a local)
707 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
708 mungeTopBinder id thing_inside mod env us
709 = case lookupIdEnv env id of
710 Just (ValBinder global) -> thing_inside global mod env us -- Already bound
712 other -> -- Give it a new print-name unless it's an exported thing
713 -- setNameVisibility also does the local/global thing
715 (id', us') | isExported id = (id, us)
717 = (setIdVisibility (Just mod) us id,
720 new_env = addToUFM env id (ValBinder id')
722 thing_inside id' mod new_env us'
724 mungeTopBinders [] k = k []
725 mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
726 mungeTopBinders bs $ \ bs' ->
729 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
730 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
732 gus' = incrUnique gus
733 lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
734 lit_id = setIdVisibility (Just mod) gus lit_local
736 (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
738 lookupId :: Id -> TidyM Id state
739 lookupId v mod env usf
740 = case lookupUFM env v of
742 Just (ValBinder v') -> (v', usf)
744 extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
745 extendEnvTM v v' m mod env usf
746 = m mod (addOneToIdEnv env v (ValBinder v')) usf
750 Making new local binders
751 ~~~~~~~~~~~~~~~~~~~~~~~~
753 newId id thing_inside mod env (gus, local_uniq, floats)
755 -- Give the Id a fresh print-name, *and* rename its type
756 local_uniq' = incrUnique local_uniq
757 name' = setNameVisibility Nothing local_uniq (getName id)
758 ty' = nmbr_ty env local_uniq' (idType id)
759 id' = mkUserId name' ty'
760 -- NB: This throws away the IdInfo of the Id, which we
761 -- no longer need. That means we don't need to
762 -- run over it with env, nor renumber it
764 -- NB: the Id's unique remains unchanged; it's only
765 -- its print name that is affected by local_uniq
767 env' = addToUFM env id (ValBinder id')
769 thing_inside id' mod env' (gus, local_uniq', floats)
771 newIds [] thing_inside
773 newIds (bndr:bndrs) thing_inside
774 = newId bndr $ \ bndr' ->
775 newIds bndrs $ \ bndrs' ->
776 thing_inside (bndr' : bndrs')
779 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
781 local_uniq' = incrUnique local_uniq
782 tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
783 env' = addToUFM env tyvar (TyBinder tyvar')
785 thing_inside tyvar' mod env' (gus, local_uniq', floats)
791 tidyTy ty mod env usf@(_, local_uniq, _)
792 = (nmbr_ty env local_uniq ty, usf)
793 -- We can use local_uniq as a base for renaming forall'd variables
794 -- in the type; we don't need to know how many are consumed.
796 -- This little impedance-matcher calls nmbrType with the right arguments
798 = nmbrType tv_env uniq ty
800 tv_env :: TyVar -> TyVar
801 tv_env tyvar = case lookupUFM env tyvar of
802 Just (TyBinder tyvar') -> tyvar'