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,
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@
240 [March 98] Indirections are now elimianted by the occurrence analyser
241 -- 1. Eliminate indirections. The point here is to transform
243 -- x_exported = x_local
247 2. Make certain top-level bindings into Globals. The point is that
248 Global things get externally-visible labels at code generation
251 3. Make the representation of NoRep literals explicit, and
252 float their bindings to the top level
255 case x of {...; x' -> ...x'...}
257 case x of {...; _ -> ...x... }
258 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
260 5. *Mangle* cases involving fork# and par# in the discriminant. The
261 original templates for these primops (see @PrelVals.lhs@) constructed
262 case expressions with boolean results solely to fool the strictness
263 analyzer, the simplifier, and anyone else who might want to fool with
264 the evaluation order. At this point in the compiler our evaluation
265 order is safe. Therefore, we convert expressions of the form:
274 6. Eliminate polymorphic case expressions. We can't generate code for them yet.
276 7. Do eta reduction for lambda abstractions appearing in:
277 - the RHS of case alternatives
279 These will otherwise turn into local bindings during Core->STG; better to
280 nuke them if possible. (In general the simplifier does eta expansion not
281 eta reduction, up to this point.)
283 8. Do let-to-case. See notes in Simplify.lhs for why we defer let-to-case
284 for multi-constructor types.
286 9. Give all binders a nice print-name. Their uniques aren't changed; rather we give
287 them lexically unique occ-names, so that we can safely print the OccNae only
288 in the interface file. [Bad idea to change the uniques, because the code
289 generator makes global labels from the uniques for local thunks etc.]
295 tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
297 tidyCorePgm mod binds_in
298 = initTM mod nullIdEnv $
299 tidyTopBindings binds_in `thenTM` \ binds ->
300 returnTM (bagToList binds)
306 tidyTopBindings [] = returnTM emptyBag
307 tidyTopBindings (b:bs)
311 tidyTopBinding :: CoreBinding
312 -> TopTidyM (Bag CoreBinding)
313 -> TopTidyM (Bag CoreBinding)
315 tidyTopBinding (NonRec bndr rhs) thing_inside
316 = initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
317 mungeTopBinder bndr $ \ bndr' ->
318 thing_inside `thenTM` \ binds ->
319 returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
321 tidyTopBinding (Rec pairs) thing_inside
322 = mungeTopBinders binders $ \ binders' ->
323 initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
324 thing_inside `thenTM` \ binds_inside ->
325 returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
327 (binders, rhss) = unzip pairs
335 tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
338 tidyCoreExpr (Lit lit)
339 = litToRep lit `thenTM` \ (_, lit_expr) ->
342 tidyCoreExpr (App fun arg)
343 = tidyCoreExpr fun `thenTM` \ fun' ->
344 tidyCoreArg arg `thenTM` \ arg' ->
345 returnTM (App fun' arg')
347 tidyCoreExpr (Con con args)
348 = mapTM tidyCoreArg args `thenTM` \ args' ->
349 returnTM (Con con args')
351 tidyCoreExpr (Prim prim args)
352 = tidyPrimOp prim `thenTM` \ prim' ->
353 mapTM tidyCoreArg args `thenTM` \ args' ->
354 returnTM (Prim prim' args')
356 tidyCoreExpr (Lam (ValBinder v) body)
358 tidyCoreExpr body `thenTM` \ body' ->
359 returnTM (Lam (ValBinder v') body')
361 tidyCoreExpr (Lam (TyBinder tv) body)
362 = newTyVar tv $ \ tv' ->
363 tidyCoreExpr body `thenTM` \ body' ->
364 returnTM (Lam (TyBinder tv') body')
366 -- Try for let-to-case (see notes in Simplify.lhs for why
367 -- some let-to-case stuff is deferred to now).
368 tidyCoreExpr (Let (NonRec bndr rhs) body)
369 | willBeDemanded (getIdDemandInfo bndr) &&
370 not rhs_is_whnf && -- Don't do it if RHS is already in WHNF
371 typeOkForCase (idType bndr)
372 = ASSERT( not (isUnpointedType (idType bndr)) )
373 tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
375 rhs_is_whnf = case mkFormSummary rhs of
380 tidyCoreExpr (Let (NonRec bndr rhs) body)
381 = tidyCoreExpr rhs `thenTM` \ rhs' ->
382 newId bndr $ \ bndr' ->
383 tidyCoreExprEta body `thenTM` \ body' ->
384 returnTM (Let (NonRec bndr' rhs') body')
386 tidyCoreExpr (Let (Rec pairs) body)
387 = newIds bndrs $ \ bndrs' ->
388 mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
389 tidyCoreExprEta body `thenTM` \ body' ->
390 returnTM (Let (Rec (bndrs' `zip` rhss')) body')
392 (bndrs, rhss) = unzip pairs
394 tidyCoreExpr (SCC cc body)
395 = tidyCoreExprEta body `thenTM` \ body' ->
396 returnTM (SCC cc body')
398 tidyCoreExpr (Coerce coercion ty body)
399 = tidyCoreExprEta body `thenTM` \ body' ->
400 tidyTy ty `thenTM` \ ty' ->
401 returnTM (Coerce coercion ty' body')
403 -- Wierd case for par, seq, fork etc. See notes above.
404 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
406 = tidyCoreExpr scrut `thenTM` \ scrut' ->
407 newId binder $ \ binder' ->
408 tidyCoreExprEta rhs `thenTM` \ rhs' ->
409 returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
411 -- Eliminate polymorphic case, for which we can't generate code just yet
412 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
413 | not (typeOkForCase (idType deflt_bndr))
414 = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $
416 Var v -> lookupId v `thenTM` \ v' ->
417 extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
418 other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
420 tidyCoreExpr (Case scrut alts)
421 = tidyCoreExpr scrut `thenTM` \ scrut' ->
422 tidy_alts scrut' alts `thenTM` \ alts' ->
423 returnTM (Case scrut' alts')
425 tidy_alts scrut (AlgAlts alts deflt)
426 = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
427 tidy_deflt scrut deflt `thenTM` \ deflt' ->
428 returnTM (AlgAlts alts' deflt')
430 tidy_alts scrut (PrimAlts alts deflt)
431 = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
432 tidy_deflt scrut deflt `thenTM` \ deflt' ->
433 returnTM (PrimAlts alts' deflt')
435 tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
436 tidyCoreExprEta rhs `thenTM` \ rhs' ->
437 returnTM (con, bndrs', rhs')
439 tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
442 -- We convert case x of {...; x' -> ...x'...}
444 -- case x of {...; _ -> ...x... }
446 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
447 -- It's quite easily done: simply extend the environment to bind the
448 -- default binder to the scrutinee.
450 tidy_deflt scrut NoDefault = returnTM NoDefault
451 tidy_deflt scrut (BindDefault bndr rhs)
452 = newId bndr $ \ bndr' ->
453 extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
454 returnTM (BindDefault bndr' rhs')
456 extend_env = case scrut of
457 Var v -> extendEnvTM bndr v
460 tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
461 returnTM (etaCoreExpr e')
467 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
469 tidyCoreArg (VarArg v)
470 = lookupId v `thenTM` \ v' ->
473 tidyCoreArg (LitArg lit)
474 = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
476 Var v -> returnTM (VarArg v)
477 Lit l -> returnTM (LitArg l)
478 other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
481 tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
486 tidyPrimOp (CCallOp fn casm gc tys ty)
487 = mapTM tidyTy tys `thenTM` \ tys' ->
488 tidyTy ty `thenTM` \ ty' ->
489 returnTM (CCallOp fn casm gc tys' ty')
491 tidyPrimOp other_prim_op = returnTM other_prim_op
495 %************************************************************************
497 \subsection[coreToStg-lits]{Converting literals}
499 %************************************************************************
501 Literals: the NoRep kind need to be de-no-rep'd.
502 We always replace them with a simple variable, and float a suitable
503 binding out to the top level.
507 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
509 litToRep (NoRepStr s)
510 = returnTM (stringTy, rhs)
512 rhs = if (any is_NUL (_UNPK_ s))
514 then -- Must cater for NULs in literal string
515 mkGenApp (Var unpackCString2Id)
517 LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
519 else -- No NULs in the string
520 App (Var unpackCStringId) (LitArg (MachStr s))
525 If an Integer is small enough (Haskell implementations must support
526 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
527 otherwise, wrap with @litString2Integer@.
530 litToRep (NoRepInteger i integer_ty)
531 = returnTM (integer_ty, rhs)
533 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
534 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
535 | i == 2 = Var integerPlusTwoId
536 | i == (-1) = Var integerMinusOneId
538 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
540 = Prim Int2IntegerOp [LitArg (mkMachInt i)]
542 | otherwise -- Big, so start from a string
543 = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
546 litToRep (NoRepRational r rational_ty)
547 = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
548 tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
549 returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
551 (ratio_data_con, integer_ty)
552 = case (splitAlgTyConApp_maybe rational_ty) of
553 Just (tycon, [i_ty], [con])
554 -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey)
557 _ -> (panic "ratio_data_con", panic "integer_ty")
559 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
563 funnyParallelOp SeqOp = True
564 funnyParallelOp ParOp = True
565 funnyParallelOp ForkOp = True
566 funnyParallelOp _ = False
570 %************************************************************************
572 \subsection{The monad}
574 %************************************************************************
577 type TidyM a state = Module
578 -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
582 type TopTidyM a = TidyM a Unique
583 type NestTidyM a = TidyM a (Unique, -- Global names
584 Unique, -- Local names
585 Bag CoreBinding) -- Floats
588 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
590 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
592 = case m mod env initialTopTidyUnique of
593 (result, _) -> result
595 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
596 initNestedTM m mod env global_us
597 = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
598 (result, (global_us', _, floats)) -> ((result, floats), global_us')
600 returnTM v mod env usf = (v, usf)
601 thenTM m k mod env usf = case m mod env usf of
602 (r, usf') -> k r mod env usf'
604 mapTM f [] = returnTM []
605 mapTM f (x:xs) = f x `thenTM` \ r ->
606 mapTM f xs `thenTM` \ rs ->
612 -- Need to extend the environment when we munge a binder, so that occurrences
613 -- of the binder will print the correct way (i.e. as a global not a local)
614 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
615 mungeTopBinder id thing_inside mod env us
616 = case lookupIdEnv env id of
617 Just (ValBinder global) -> thing_inside global mod env us -- Already bound
619 other -> -- Give it a new print-name unless it's an exported thing
620 -- setNameVisibility also does the local/global thing
622 (id', us') | isExported id = (id, us)
624 = (setIdVisibility (Just mod) us id,
627 new_env = addToUFM env id (ValBinder id')
629 thing_inside id' mod new_env us'
631 mungeTopBinders [] k = k []
632 mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
633 mungeTopBinders bs $ \ bs' ->
636 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
637 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
639 gus' = incrUnique gus
640 lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
641 lit_id = setIdVisibility (Just mod) gus lit_local
643 (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
645 lookupId :: Id -> TidyM Id state
646 lookupId v mod env usf
647 = case lookupUFM env v of
649 Just (ValBinder v') -> (v', usf)
651 extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
652 extendEnvTM v v' m mod env usf
653 = m mod (addOneToIdEnv env v (ValBinder v')) usf
657 Making new local binders
658 ~~~~~~~~~~~~~~~~~~~~~~~~
660 newId id thing_inside mod env (gus, local_uniq, floats)
662 -- Give the Id a fresh print-name, *and* rename its type
663 local_uniq' = incrUnique local_uniq
664 name' = setNameVisibility Nothing local_uniq (getName id)
665 ty' = nmbr_ty env local_uniq' (idType id)
666 id' = mkUserId name' ty'
667 -- NB: This throws away the IdInfo of the Id, which we
668 -- no longer need. That means we don't need to
669 -- run over it with env, nor renumber it
671 -- NB: the Id's unique remains unchanged; it's only
672 -- its print name that is affected by local_uniq
674 env' = addToUFM env id (ValBinder id')
676 thing_inside id' mod env' (gus, local_uniq', floats)
678 newIds [] thing_inside
680 newIds (bndr:bndrs) thing_inside
681 = newId bndr $ \ bndr' ->
682 newIds bndrs $ \ bndrs' ->
683 thing_inside (bndr' : bndrs')
686 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
688 local_uniq' = incrUnique local_uniq
689 tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
690 env' = addToUFM env tyvar (TyBinder tyvar')
692 thing_inside tyvar' mod env' (gus, local_uniq', floats)
698 tidyTy ty mod env usf@(_, local_uniq, _)
699 = (nmbr_ty env local_uniq ty, usf)
700 -- We can use local_uniq as a base for renaming forall'd variables
701 -- in the type; we don't need to know how many are consumed.
703 -- This little impedance-matcher calls nmbrType with the right arguments
705 = nmbrType tv_env uniq ty
707 tv_env :: TyVar -> TyVar
708 tv_env tyvar = case lookupUFM env tyvar of
709 Just (TyBinder tyvar') -> tyvar'