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, mkMachInt_safe )
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 MkId ( mkSysLocal, mkUserId )
37 import Id ( setIdVisibility, getIdSpecialisation, setIdSpecialisation,
38 getIdDemandInfo, idType,
39 nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
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 ( nmbrType )
61 import SAT ( doStaticArgs )
62 import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
63 import SimplPgm ( simplifyPgm )
65 import SpecEnv ( substSpecEnv, isEmptySpecEnv )
66 import StrictAnal ( saWwTopBinds )
67 import TyVar ( TyVar, nameTyVar, emptyTyVarEnv )
68 import Unique ( Unique{-instance Eq-}, Uniquable(..),
69 integerTyConKey, ratioTyConKey,
73 import UniqSupply ( UniqSupply, mkSplitUniqSupply,
74 splitUniqSupply, getUnique
76 import UniqFM ( UniqFM, lookupUFM, addToUFM, delFromUFM )
77 import Util ( mapAccumL )
78 import SrcLoc ( noSrcLoc )
79 import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
82 import IO ( hPutStr, stderr )
87 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
88 -> FAST_STRING -- module name (profiling only)
89 -> UniqSupply -- a name supply
90 -> [TyCon] -- local data tycons and tycon specialisations
91 -> [CoreBinding] -- input...
92 -> IO [CoreBinding] -- results: program
94 core2core core_todos module_name us local_tycons binds
95 = -- Do the main business
97 (binds, us, zeroSimplCount)
99 >>= \ (processed_binds, us', simpl_stats) ->
101 -- Do the final tidy-up
103 final_binds = tidyCorePgm module_name processed_binds
105 lintCoreBindings "TidyCorePgm" True final_binds >>
109 dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core)
110 "Core transformations"
111 (pprCoreBindings final_binds) >>
114 doIfSet opt_D_simplifier_stats
115 (hPutStr stderr ("\nSimplifier Stats:\n") >>
116 hPutStr stderr (showSimplCount simpl_stats) >>
117 hPutStr stderr "\n") >>
123 do_core_pass info@(binds, us, simpl_stats) to_do =
124 case (splitUniqSupply us) of
127 CoreDoSimplify simpl_sw_chkr
128 -> _scc_ "CoreSimplify"
129 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
130 then " (foldr/build)" else "") >>
131 case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
132 (p, it_cnt, simpl_stats2)
133 -> end_pass us2 p simpl_stats2
134 ("Simplify (" ++ show it_cnt ++ ")"
135 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
136 then " foldr/build" else "")
138 CoreDoFoldrBuildWorkerWrapper
139 -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
141 case (mkFoldrBuildWW us1 binds) of { binds2 ->
142 end_pass us2 binds2 simpl_stats "FBWW" }
144 CoreDoFoldrBuildWWAnal
145 -> _scc_ "CoreDoFoldrBuildWWAnal"
146 begin_pass "AnalFBWW" >>
147 case (analFBWW binds) of { binds2 ->
148 end_pass us2 binds2 simpl_stats "AnalFBWW" }
151 -> _scc_ "LiberateCase"
152 begin_pass "LiberateCase" >>
153 case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
154 end_pass us2 binds2 simpl_stats "LiberateCase" }
157 -> _scc_ "FloatInwards"
158 begin_pass "FloatIn" >>
159 case (floatInwards binds) of { binds2 ->
160 end_pass us2 binds2 simpl_stats "FloatIn" }
163 -> _scc_ "CoreFloating"
164 begin_pass "FloatOut" >>
165 case (floatOutwards us1 binds) of { binds2 ->
166 end_pass us2 binds2 simpl_stats "FloatOut" }
169 -> _scc_ "CoreStaticArgs"
170 begin_pass "StaticArgs" >>
171 case (doStaticArgs binds us1) of { binds2 ->
172 end_pass us2 binds2 simpl_stats "StaticArgs" }
173 -- Binds really should be dependency-analysed for static-
174 -- arg transformation... Not to worry, they probably are.
175 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
178 -> _scc_ "CoreStranal"
179 begin_pass "StrAnal" >>
180 case (saWwTopBinds us1 binds) of { binds2 ->
181 end_pass us2 binds2 simpl_stats "StrAnal" }
184 -> _scc_ "Specialise"
185 begin_pass "Specialise" >>
186 case (specProgram us1 binds) of { p ->
187 end_pass us2 p simpl_stats "Specialise"
190 CoreDoPrintCore -- print result of last pass
191 -> dumpIfSet (not opt_D_verbose_core2core) "Print Core"
192 (pprCoreBindings binds) >>
193 return (binds, us1, simpl_stats)
195 -------------------------------------------------
198 = if opt_D_show_passes
199 then hPutStr stderr ("*** Core2Core: "++what++"\n")
204 = -- Report verbosely, if required
205 dumpIfSet opt_D_verbose_core2core what
206 (pprCoreBindings binds2) >>
208 lintCoreBindings what True {- spec_done -} binds2 >>
209 -- The spec_done flag tells the linter to
210 -- complain about unboxed let-bindings
211 -- But we're not specialising unboxed types any more,
212 -- so its irrelevant.
215 (binds2, -- processed binds, possibly run thru CoreLint
216 us2, -- UniqSupply for the next guy
217 simpl_stats2 -- accumulated simplifier stats
221 -- here so it can be inlined...
222 foldl_mn f z [] = return z
223 foldl_mn f z (x:xs) = f z x >>= \ zz ->
229 %************************************************************************
231 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
233 %************************************************************************
235 Several tasks are done by @tidyCorePgm@
238 [March 98] Indirections are now elimianted by the occurrence analyser
239 -- 1. Eliminate indirections. The point here is to transform
241 -- x_exported = x_local
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.]
293 tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
295 tidyCorePgm mod binds_in
296 = initTM mod nullIdEnv $
297 tidyTopBindings binds_in `thenTM` \ binds ->
298 returnTM (bagToList binds)
304 tidyTopBindings [] = returnTM emptyBag
305 tidyTopBindings (b:bs)
309 tidyTopBinding :: CoreBinding
310 -> TopTidyM (Bag CoreBinding)
311 -> TopTidyM (Bag CoreBinding)
313 tidyTopBinding (NonRec bndr rhs) thing_inside
314 = initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
315 mungeTopBinder bndr $ \ bndr' ->
316 thing_inside `thenTM` \ binds ->
317 returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
319 tidyTopBinding (Rec pairs) thing_inside
320 = mungeTopBinders binders $ \ binders' ->
321 initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
322 thing_inside `thenTM` \ binds_inside ->
323 returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
325 (binders, rhss) = unzip pairs
333 tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
336 tidyCoreExpr (Lit lit)
337 = litToRep lit `thenTM` \ (_, lit_expr) ->
340 tidyCoreExpr (App fun arg)
341 = tidyCoreExpr fun `thenTM` \ fun' ->
342 tidyCoreArg arg `thenTM` \ arg' ->
343 returnTM (App fun' arg')
345 tidyCoreExpr (Con con args)
346 = mapTM tidyCoreArg args `thenTM` \ args' ->
347 returnTM (Con con args')
349 tidyCoreExpr (Prim prim args)
350 = tidyPrimOp prim `thenTM` \ prim' ->
351 mapTM tidyCoreArg args `thenTM` \ args' ->
352 returnTM (Prim prim' args')
354 tidyCoreExpr (Lam (ValBinder v) body)
356 tidyCoreExpr body `thenTM` \ body' ->
357 returnTM (Lam (ValBinder v') body')
359 tidyCoreExpr (Lam (TyBinder tv) body)
360 = newTyVar tv $ \ tv' ->
361 tidyCoreExpr body `thenTM` \ body' ->
362 returnTM (Lam (TyBinder tv') body')
364 -- Try for let-to-case (see notes in Simplify.lhs for why
365 -- some let-to-case stuff is deferred to now).
366 tidyCoreExpr (Let (NonRec bndr rhs) body)
367 | willBeDemanded (getIdDemandInfo bndr) &&
368 not rhs_is_whnf && -- Don't do it if RHS is already in WHNF
369 typeOkForCase (idType bndr)
370 = ASSERT( not (isUnpointedType (idType bndr)) )
371 tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
373 rhs_is_whnf = case mkFormSummary rhs of
378 tidyCoreExpr (Let (NonRec bndr rhs) body)
379 = tidyCoreExpr rhs `thenTM` \ rhs' ->
380 newId bndr $ \ bndr' ->
381 tidyCoreExprEta body `thenTM` \ body' ->
382 returnTM (Let (NonRec bndr' rhs') body')
384 tidyCoreExpr (Let (Rec pairs) body)
385 = newIds bndrs $ \ bndrs' ->
386 mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
387 tidyCoreExprEta body `thenTM` \ body' ->
388 returnTM (Let (Rec (bndrs' `zip` rhss')) body')
390 (bndrs, rhss) = unzip pairs
392 tidyCoreExpr (Note (Coerce to_ty from_ty) body)
393 = tidyCoreExprEta body `thenTM` \ body' ->
394 tidyTy to_ty `thenTM` \ to_ty' ->
395 tidyTy from_ty `thenTM` \ from_ty' ->
396 returnTM (Note (Coerce to_ty' from_ty') body')
398 tidyCoreExpr (Note note body)
399 = tidyCoreExprEta body `thenTM` \ body' ->
400 returnTM (Note note body')
402 -- Wierd case for par, seq, fork etc. See notes above.
403 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
405 = tidyCoreExpr scrut `thenTM` \ scrut' ->
406 newId binder $ \ binder' ->
407 tidyCoreExprEta rhs `thenTM` \ rhs' ->
408 returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
410 -- Eliminate polymorphic case, for which we can't generate code just yet
411 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
412 | not (typeOkForCase (idType deflt_bndr))
413 = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $
415 Var v -> lookupId v `thenTM` \ v' ->
416 extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
417 other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
419 tidyCoreExpr (Case scrut alts)
420 = tidyCoreExpr scrut `thenTM` \ scrut' ->
421 tidy_alts scrut' alts `thenTM` \ alts' ->
422 returnTM (Case scrut' alts')
424 tidy_alts scrut (AlgAlts alts deflt)
425 = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
426 tidy_deflt scrut deflt `thenTM` \ deflt' ->
427 returnTM (AlgAlts alts' deflt')
429 tidy_alts scrut (PrimAlts alts deflt)
430 = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
431 tidy_deflt scrut deflt `thenTM` \ deflt' ->
432 returnTM (PrimAlts alts' deflt')
434 tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
435 tidyCoreExprEta rhs `thenTM` \ rhs' ->
436 returnTM (con, bndrs', rhs')
438 tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
441 -- We convert case x of {...; x' -> ...x'...}
443 -- case x of {...; _ -> ...x... }
445 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
446 -- It's quite easily done: simply extend the environment to bind the
447 -- default binder to the scrutinee.
449 tidy_deflt scrut NoDefault = returnTM NoDefault
450 tidy_deflt scrut (BindDefault bndr rhs)
451 = newId bndr $ \ bndr' ->
452 extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
453 returnTM (BindDefault bndr' rhs')
455 extend_env = case scrut of
456 Var v -> extendEnvTM bndr v
459 tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
460 returnTM (etaCoreExpr e')
466 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
468 tidyCoreArg (VarArg v)
469 = lookupId v `thenTM` \ v' ->
472 tidyCoreArg (LitArg lit)
473 = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
475 Var v -> returnTM (VarArg v)
476 Lit l -> returnTM (LitArg l)
477 other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
480 tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
485 tidyPrimOp (CCallOp fn casm gc cconv tys ty)
486 = mapTM tidyTy tys `thenTM` \ tys' ->
487 tidyTy ty `thenTM` \ ty' ->
488 returnTM (CCallOp fn casm gc cconv tys' ty')
490 tidyPrimOp other_prim_op = returnTM other_prim_op
494 %************************************************************************
496 \subsection[coreToStg-lits]{Converting literals}
498 %************************************************************************
500 Literals: the NoRep kind need to be de-no-rep'd.
501 We always replace them with a simple variable, and float a suitable
502 binding out to the top level.
506 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
508 litToRep (NoRepStr s)
509 = returnTM (stringTy, rhs)
511 rhs = if (any is_NUL (_UNPK_ s))
513 then -- Must cater for NULs in literal string
514 mkGenApp (Var unpackCString2Id)
516 LitArg (mkMachInt_safe (toInteger (_LENGTH_ s)))]
518 else -- No NULs in the string
519 App (Var unpackCStringId) (LitArg (MachStr s))
524 If an Integer is small enough (Haskell implementations must support
525 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
526 otherwise, wrap with @litString2Integer@.
529 litToRep (NoRepInteger i integer_ty)
530 = returnTM (integer_ty, rhs)
532 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
533 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
534 | i == 2 = Var integerPlusTwoId
535 | i == (-1) = Var integerMinusOneId
537 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
539 = Prim Int2IntegerOp [LitArg (mkMachInt (fromInteger i))]
541 | otherwise -- Big, so start from a string
542 = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
545 litToRep (NoRepRational r rational_ty)
546 = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
547 tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
548 returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
550 (ratio_data_con, integer_ty)
551 = case (splitAlgTyConApp_maybe rational_ty) of
552 Just (tycon, [i_ty], [con])
553 -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey)
556 _ -> (panic "ratio_data_con", panic "integer_ty")
558 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
562 funnyParallelOp SeqOp = True
563 funnyParallelOp ParOp = True
564 funnyParallelOp ForkOp = True
565 funnyParallelOp _ = False
569 %************************************************************************
571 \subsection{The monad}
573 %************************************************************************
576 type TidyM a state = Module
577 -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
581 type TopTidyM a = TidyM a Unique
582 type NestTidyM a = TidyM a (Unique, -- Global names
583 Unique, -- Local names
584 Bag CoreBinding) -- Floats
587 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
589 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
591 = case m mod env initialTopTidyUnique of
592 (result, _) -> result
594 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
595 initNestedTM m mod env global_us
596 = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
597 (result, (global_us', _, floats)) -> ((result, floats), global_us')
599 returnTM v mod env usf = (v, usf)
600 thenTM m k mod env usf = case m mod env usf of
601 (r, usf') -> k r mod env usf'
603 mapTM f [] = returnTM []
604 mapTM f (x:xs) = f x `thenTM` \ r ->
605 mapTM f xs `thenTM` \ rs ->
611 -- Need to extend the environment when we munge a binder, so that occurrences
612 -- of the binder will print the correct way (e.g. as a global not a local)
613 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
614 mungeTopBinder id thing_inside mod env us
615 = -- Give it a new print-name unless it's an exported thing
616 -- setNameVisibility also does the local/global thing
618 (id1, us') | isExported id = (id, us)
620 = (setIdVisibility (Just mod) us id,
623 -- Tidy the Id's SpecEnv
624 spec_env = getIdSpecialisation id
625 id2 | isEmptySpecEnv spec_env = id1
626 | otherwise = setIdSpecialisation id1 (tidySpecEnv env spec_env)
628 new_env = addToUFM env id (ValBinder id2)
630 thing_inside id2 mod new_env us'
632 tidySpecEnv env spec_env
634 emptyTyVarEnv -- Top level only
638 -- tidy_spec_rhs is another horrid little hacked-up function for
639 -- the RHS of specialisation templates.
640 -- It assumes there is no type substitution.
642 -- See also SimplVar.substSpecEnvRhs Urgh
643 tidy_spec_rhs env (Var v) = case lookupUFM env v of
644 Just (ValBinder v') -> Var v'
646 tidy_spec_rhs env (App f (VarArg v)) = App (tidy_spec_rhs env f) (case lookupUFM env v of
647 Just (ValBinder v') -> VarArg v'
649 tidy_spec_rhs env (App f arg) = App (tidy_spec_rhs env f) arg
650 tidy_spec_rhs env (Lam b e) = Lam b (tidy_spec_rhs env' e)
653 ValBinder id -> delFromUFM env id
656 mungeTopBinders [] k = k []
657 mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
658 mungeTopBinders bs $ \ bs' ->
661 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
662 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
664 gus' = incrUnique gus
665 lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
666 lit_id = setIdVisibility (Just mod) gus lit_local
668 (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
670 lookupId :: Id -> TidyM Id state
671 lookupId v mod env usf
672 = case lookupUFM env v of
674 Just (ValBinder v') -> (v', usf)
676 extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
677 extendEnvTM v v' m mod env usf
678 = m mod (addOneToIdEnv env v (ValBinder v')) usf
682 Making new local binders
683 ~~~~~~~~~~~~~~~~~~~~~~~~
685 newId id thing_inside mod env (gus, local_uniq, floats)
687 -- Give the Id a fresh print-name, *and* rename its type
688 local_uniq' = incrUnique local_uniq
689 name' = setNameVisibility Nothing local_uniq (getName id)
690 ty' = nmbr_ty env local_uniq' (idType id)
691 id' = mkUserId name' ty'
692 -- NB: This throws away the IdInfo of the Id, which we
693 -- no longer need. That means we don't need to
694 -- run over it with env, nor renumber it
696 -- NB: the Id's unique remains unchanged; it's only
697 -- its print name that is affected by local_uniq
699 env' = addToUFM env id (ValBinder id')
701 thing_inside id' mod env' (gus, local_uniq', floats)
703 newIds [] thing_inside
705 newIds (bndr:bndrs) thing_inside
706 = newId bndr $ \ bndr' ->
707 newIds bndrs $ \ bndrs' ->
708 thing_inside (bndr' : bndrs')
711 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
713 local_uniq' = incrUnique local_uniq
714 tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
715 env' = addToUFM env tyvar (TyBinder tyvar')
717 thing_inside tyvar' mod env' (gus, local_uniq', floats)
723 tidyTy ty mod env usf@(_, local_uniq, _)
724 = (nmbr_ty env local_uniq ty, usf)
725 -- We can use local_uniq as a base for renaming forall'd variables
726 -- in the type; we don't need to know how many are consumed.
728 -- This little impedance-matcher calls nmbrType with the right arguments
730 = nmbrType tv_env uniq ty
732 tv_env :: TyVar -> TyVar
733 tv_env tyvar = case lookupUFM env tyvar of
734 Just (TyBinder tyvar') -> tyvar'