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,
20 opt_D_verbose_core2core,
23 opt_ReportWhyUnfoldingsDisallowed,
25 opt_LiberateCaseThreshold
27 import CoreLint ( lintCoreBindings )
29 import CoreUtils ( coreExprType )
30 import SimplUtils ( etaCoreExpr, typeOkForCase )
32 import Literal ( Literal(..), literalType, mkMachInt )
33 import ErrUtils ( ghcExit )
34 import FiniteMap ( FiniteMap )
35 import FloatIn ( floatInwards )
36 import FloatOut ( floatOutwards )
37 import FoldrBuildWW ( mkFoldrBuildWW )
38 import Id ( mkSysLocal, setIdVisibility, replaceIdInfo,
39 replacePragmaInfo, getIdDemandInfo, idType,
40 getIdInfo, getPragmaInfo, mkIdWithNewUniq,
41 nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
42 lookupIdEnv, SYN_IE(IdEnv), omitIfaceSigForId,
44 GenId{-instance Outputable-}, SYN_IE(Id)
46 import IdInfo ( willBeDemanded, DemandInfo )
47 import Name ( isExported, isLocallyDefined,
48 isLocalName, uniqToOccName,
49 SYN_IE(Module), NamedThing(..), OccName(..)
51 import TyCon ( TyCon )
52 import PrimOp ( PrimOp(..) )
53 import PrelVals ( unpackCStringId, unpackCString2Id,
54 integerZeroId, integerPlusOneId,
55 integerPlusTwoId, integerMinusOneId
57 import Type ( maybeAppDataTyCon, isPrimType, SYN_IE(Type) )
58 import TysWiredIn ( stringTy, isIntegerTy )
59 import LiberateCase ( liberateCase )
60 import MagicUFs ( MagicUnfoldingFun )
61 import Outputable ( PprStyle(..), Outputable(..){-instance * (,) -} )
63 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-},
66 import Pretty ( Doc, vcat, ($$), hsep )
67 import SAT ( doStaticArgs )
68 import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
69 import SimplPgm ( simplifyPgm )
71 import SpecUtils ( pprSpecErrs )
72 import StrictAnal ( saWwTopBinds )
73 import TyVar ( SYN_IE(TyVar), nullTyVarEnv, GenTyVar{-instance Eq-},
76 import Unique ( Unique{-instance Eq-}, Uniquable(..),
77 integerTyConKey, ratioTyConKey,
81 import UniqSupply ( UniqSupply, mkSplitUniqSupply,
82 splitUniqSupply, getUnique
84 import UniqFM ( UniqFM, lookupUFM, addToUFM )
85 import Usage ( SYN_IE(UVar), cloneUVar )
86 import Util ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic )
87 import SrcLoc ( noSrcLoc )
88 import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
93 #ifndef OMIT_DEFORESTER
94 import Deforest ( deforestProgram )
95 import DefUtils ( deforestable )
101 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
102 -> FAST_STRING -- module name (profiling only)
103 -> PprStyle -- printing style (for debugging only)
104 -> UniqSupply -- a name supply
105 -> [TyCon] -- local data tycons and tycon specialisations
106 -> FiniteMap TyCon [(Bool, [Maybe Type])]
107 -> [CoreBinding] -- input...
109 ([CoreBinding], -- results: program, plus...
110 SpecialiseData) -- specialisation data
112 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
114 (if opt_D_verbose_core2core then
115 hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
118 -- Do the main business
119 foldl_mn do_core_pass
120 (binds, us, init_specdata, zeroSimplCount)
122 >>= \ (processed_binds, us', spec_data, simpl_stats) ->
124 -- Do the final tidy-up
126 final_binds = core_linter "TidyCorePgm" True $
127 tidyCorePgm module_name processed_binds
131 (if opt_D_simplifier_stats then
132 hPutStr stderr ("\nSimplifier Stats:\n") >>
133 hPutStr stderr (showSimplCount simpl_stats) >>
138 return (final_binds, spec_data)
140 init_specdata = initSpecData local_tycons tycon_specs
143 core_linter what spec_done
144 = if opt_DoCoreLinting
145 then (if opt_D_show_passes then
146 trace ("\n*** Core Lint result of " ++ what)
149 lintCoreBindings ppr_style what spec_done
153 do_core_pass info@(binds, us, spec_data, simpl_stats) to_do =
154 case (splitUniqSupply us) of
157 CoreDoSimplify simpl_sw_chkr
158 -> _scc_ "CoreSimplify"
159 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
160 then " (foldr/build)" else "") >>
161 case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
162 (p, it_cnt, simpl_stats2)
163 -> end_pass False us2 p spec_data simpl_stats2
164 ("Simplify (" ++ show it_cnt ++ ")"
165 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
166 then " foldr/build" else "")
168 CoreDoFoldrBuildWorkerWrapper
169 -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
171 case (mkFoldrBuildWW us1 binds) of { binds2 ->
172 end_pass False us2 binds2 spec_data simpl_stats "FBWW" }
174 CoreDoFoldrBuildWWAnal
175 -> _scc_ "CoreDoFoldrBuildWWAnal"
176 begin_pass "AnalFBWW" >>
177 case (analFBWW binds) of { binds2 ->
178 end_pass False us2 binds2 spec_data simpl_stats "AnalFBWW" }
181 -> _scc_ "LiberateCase"
182 begin_pass "LiberateCase" >>
183 case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
184 end_pass False us2 binds2 spec_data simpl_stats "LiberateCase" }
187 -> _scc_ "FloatInwards"
188 begin_pass "FloatIn" >>
189 case (floatInwards binds) of { binds2 ->
190 end_pass False us2 binds2 spec_data simpl_stats "FloatIn" }
193 -> _scc_ "CoreFloating"
194 begin_pass "FloatOut" >>
195 case (floatOutwards us1 binds) of { binds2 ->
196 end_pass False us2 binds2 spec_data simpl_stats "FloatOut" }
199 -> _scc_ "CoreStaticArgs"
200 begin_pass "StaticArgs" >>
201 case (doStaticArgs binds us1) of { binds2 ->
202 end_pass False us2 binds2 spec_data simpl_stats "StaticArgs" }
203 -- Binds really should be dependency-analysed for static-
204 -- arg transformation... Not to worry, they probably are.
205 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
208 -> _scc_ "CoreStranal"
209 begin_pass "StrAnal" >>
210 case (saWwTopBinds us1 binds) of { binds2 ->
211 end_pass False us2 binds2 spec_data simpl_stats "StrAnal" }
214 -> _scc_ "Specialise"
215 begin_pass "Specialise" >>
216 case (specProgram us1 binds spec_data) of {
217 (p, spec_data2@(SpecData _ spec_noerrs _ _ _
218 spec_errs spec_warn spec_tyerrs)) ->
220 -- if we got errors, we die straight away
221 (if not spec_noerrs ||
222 (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
224 (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
225 >> hPutStr stderr "\n"
229 (if not spec_noerrs then -- Stop here if specialisation errors occured
234 end_pass False us2 p spec_data2 simpl_stats "Specialise"
239 -> error "ERROR: CoreDoDeforest: not built into compiler\n"
241 -> _scc_ "Deforestation"
242 begin_pass "Deforestation" >>
243 case (deforestProgram binds us1) of { binds2 ->
244 end_pass False us2 binds2 spec_data simpl_stats "Deforestation" }
247 CoreDoPrintCore -- print result of last pass
248 -> end_pass True us2 binds spec_data simpl_stats "Print"
250 -------------------------------------------------
253 = if opt_D_show_passes
254 then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
255 else \ what -> return ()
257 end_pass print us2 binds2
258 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
260 = -- report verbosely, if required
261 (if (opt_D_verbose_core2core && not print) ||
262 (print && not opt_D_verbose_core2core)
264 hPutStr stderr ("\n*** "++what++":\n")
267 (vcat (map (pprCoreBinding ppr_style) binds2)))
273 linted_binds = core_linter what spec_done binds2
276 (linted_binds, -- processed binds, possibly run thru CoreLint
277 us2, -- UniqSupply for the next guy
278 spec_data2, -- possibly-updated specialisation info
279 simpl_stats2 -- accumulated simplifier stats
282 -- here so it can be inlined...
283 foldl_mn f z [] = return z
284 foldl_mn f z (x:xs) = f z x >>= \ zz ->
290 %************************************************************************
292 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
294 %************************************************************************
296 Several tasks are done by @tidyCorePgm@
298 1. Eliminate indirections. The point here is to transform
304 2. Make certain top-level bindings into Globals. The point is that
305 Global things get externally-visible labels at code generation
308 3. Make the representation of NoRep literals explicit, and
309 float their bindings to the top level
312 case x of {...; x' -> ...x'...}
314 case x of {...; _ -> ...x... }
315 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
317 5. *Mangle* cases involving fork# and par# in the discriminant. The
318 original templates for these primops (see @PrelVals.lhs@) constructed
319 case expressions with boolean results solely to fool the strictness
320 analyzer, the simplifier, and anyone else who might want to fool with
321 the evaluation order. At this point in the compiler our evaluation
322 order is safe. Therefore, we convert expressions of the form:
331 6. Eliminate polymorphic case expressions. We can't generate code for them yet.
333 7. Do eta reduction for lambda abstractions appearing in:
334 - the RHS of case alternatives
336 These will otherwise turn into local bindings during Core->STG; better to
337 nuke them if possible. (In general the simplifier does eta expansion not
338 eta reduction, up to this point.)
340 8. Do let-to-case. See notes in Simplify.lhs for why we defer let-to-case
341 for multi-constructor types.
343 9. Give all binders a nice print-name. Their uniques aren't changed; rather we give
344 them lexically unique occ-names, so that we can safely print the OccNae only
345 in the interface file. [Bad idea to change the uniques, because the code
346 generator makes global labels from the uniques for local thunks etc.]
349 Eliminate indirections
350 ~~~~~~~~~~~~~~~~~~~~~~
351 In @elimIndirections@, we look for things at the top-level of the form...
356 In cases we find like this, we go {\em backwards} and replace
357 \tr{x_local} with \tr{x_exported}. This save a gratuitous jump
358 (from \tr{x_exported} to \tr{x_local}), and makes strictness
359 information propagate better.
361 We rely on prior eta reduction to simplify things like
363 x_exported = /\ tyvars -> x_local tyvars
368 If more than one exported thing is equal to a local thing (i.e., the
369 local thing really is shared), then we do one only:
372 x_exported1 = x_local
373 x_exported2 = x_local
377 x_exported2 = x_exported1
380 There's a possibility of leaving unchanged something like this:
383 x_exported1 = x_local Int
385 By the time we've thrown away the types in STG land this
386 could be eliminated. But I don't think it's very common
387 and it's dangerous to do this fiddling in STG land
388 because we might elminate a binding that's mentioned in the
389 unfolding for something.
391 General Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
392 Then blast the whole program (LHSs as well as RHSs) with it.
397 tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
399 tidyCorePgm mod binds_in
400 = initTM mod indirection_env $
401 tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds ->
402 returnTM (bagToList binds)
404 (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
406 try_bind :: IdEnv CoreBinder -> CoreBinding -> (IdEnv CoreBinder, Maybe CoreBinding)
407 try_bind env_so_far (NonRec exported_binder rhs)
408 | isExported exported_binder && -- Only if this is exported
409 maybeToBool maybe_rhs_id && -- and the RHS is a simple Id
411 isLocallyDefined rhs_id && -- Only if this one is defined in this
412 -- module, so that we *can* change its
413 -- binding to be the exported thing!
415 not (isExported rhs_id) && -- Only if this one is not itself exported,
416 -- since the transformation will nuke it
418 not (omitIfaceSigForId rhs_id) && -- Don't do the transformation if rhs_id is
419 -- something like a constructor, whose
420 -- definition is implicitly exported and
421 -- which must not vanish.
422 -- To illustrate the preceding check consider
426 -- Here, we'll make a local, non-exported, defn for MkT, and without the
427 -- above condition we'll transform it to:
430 -- This is bad because mkT will get the IdDetails of MkT, and won't
431 -- be exported. Also the code generator won't make a definition for
432 -- the MkT constructor.
433 -- Slightly gruesome, this.
435 not (maybeToBool (lookupIdEnv env_so_far rhs_id))
436 -- Only if not already substituted for
438 = (addOneToIdEnv env_so_far rhs_id (ValBinder new_rhs_id), Nothing)
440 maybe_rhs_id = case etaCoreExpr rhs of
441 Var rhs_id -> Just rhs_id
443 Just rhs_id = maybe_rhs_id
444 new_rhs_id = exported_binder `replaceIdInfo` getIdInfo rhs_id
445 `replacePragmaInfo` getPragmaInfo rhs_id
446 -- NB: we keep the Pragmas and IdInfo for the old rhs_id!
447 -- This is important; it might be marked "no-inline" by
448 -- the occurrence analyser (because it's recursive), and
449 -- we must not lose that information.
451 try_bind env_so_far bind
452 = (env_so_far, Just bind)
458 tidyTopBindings [] = returnTM emptyBag
459 tidyTopBindings (b:bs)
463 tidyTopBinding :: CoreBinding
464 -> TopTidyM (Bag CoreBinding)
465 -> TopTidyM (Bag CoreBinding)
467 tidyTopBinding (NonRec bndr rhs) thing_inside
468 = initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
469 mungeTopBinder bndr $ \ bndr' ->
470 thing_inside `thenTM` \ binds ->
471 returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
473 tidyTopBinding (Rec pairs) thing_inside
474 = mungeTopBinders binders $ \ binders' ->
475 initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
476 thing_inside `thenTM` \ binds_inside ->
477 returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
479 (binders, rhss) = unzip pairs
487 tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
490 tidyCoreExpr (Lit lit)
491 = litToRep lit `thenTM` \ (_, lit_expr) ->
494 tidyCoreExpr (App fun arg)
495 = tidyCoreExpr fun `thenTM` \ fun' ->
496 tidyCoreArg arg `thenTM` \ arg' ->
497 returnTM (App fun' arg')
499 tidyCoreExpr (Con con args)
500 = mapTM tidyCoreArg args `thenTM` \ args' ->
501 returnTM (Con con args')
503 tidyCoreExpr (Prim prim args)
504 = tidyPrimOp prim `thenTM` \ prim' ->
505 mapTM tidyCoreArg args `thenTM` \ args' ->
506 returnTM (Prim prim' args')
508 tidyCoreExpr (Lam (ValBinder v) body)
510 tidyCoreExpr body `thenTM` \ body' ->
511 returnTM (Lam (ValBinder v') body')
513 tidyCoreExpr (Lam (TyBinder tv) body)
514 = newTyVar tv $ \ tv' ->
515 tidyCoreExpr body `thenTM` \ body' ->
516 returnTM (Lam (TyBinder tv') body')
518 tidyCoreExpr (Lam (UsageBinder uv) body)
519 = newUVar uv $ \ uv' ->
520 tidyCoreExpr body `thenTM` \ body' ->
521 returnTM (Lam (UsageBinder uv') body')
523 -- Try for let-to-case (see notes in Simplify.lhs for why
524 -- some let-to-case stuff is deferred to now).
525 tidyCoreExpr (Let (NonRec bndr rhs) body)
526 | willBeDemanded (getIdDemandInfo bndr) &&
527 typeOkForCase (idType bndr)
528 = ASSERT( not (isPrimType (idType bndr)) )
529 tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
531 tidyCoreExpr (Let (NonRec bndr rhs) body)
532 = tidyCoreExpr rhs `thenTM` \ rhs' ->
533 newId bndr $ \ bndr' ->
534 tidyCoreExprEta body `thenTM` \ body' ->
535 returnTM (Let (NonRec bndr' rhs') body')
537 tidyCoreExpr (Let (Rec pairs) body)
538 = newIds bndrs $ \ bndrs' ->
539 mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
540 tidyCoreExprEta body `thenTM` \ body' ->
541 returnTM (Let (Rec (bndrs' `zip` rhss')) body')
543 (bndrs, rhss) = unzip pairs
545 tidyCoreExpr (SCC cc body)
546 = tidyCoreExprEta body `thenTM` \ body' ->
547 returnTM (SCC cc body')
549 tidyCoreExpr (Coerce coercion ty body)
550 = tidyCoreExprEta body `thenTM` \ body' ->
551 tidyTy ty `thenTM` \ ty' ->
552 returnTM (Coerce coercion ty' body')
554 -- Wierd case for par, seq, fork etc. See notes above.
555 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
557 = tidyCoreExpr scrut `thenTM` \ scrut' ->
558 newId binder $ \ binder' ->
559 tidyCoreExprEta rhs `thenTM` \ rhs' ->
560 returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
562 -- Eliminate polymorphic case, for which we can't generate code just yet
563 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
564 | not (typeOkForCase (idType deflt_bndr))
565 = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $
567 Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs)
568 other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
570 tidyCoreExpr (Case scrut alts)
571 = tidyCoreExpr scrut `thenTM` \ scrut' ->
572 tidy_alts scrut' alts `thenTM` \ alts' ->
573 returnTM (Case scrut' alts')
575 tidy_alts scrut (AlgAlts alts deflt)
576 = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
577 tidy_deflt scrut deflt `thenTM` \ deflt' ->
578 returnTM (AlgAlts alts' deflt')
580 tidy_alts scrut (PrimAlts alts deflt)
581 = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
582 tidy_deflt scrut deflt `thenTM` \ deflt' ->
583 returnTM (PrimAlts alts' deflt')
585 tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
586 tidyCoreExprEta rhs `thenTM` \ rhs' ->
587 returnTM (con, bndrs', rhs')
589 tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
592 -- We convert case x of {...; x' -> ...x'...}
594 -- case x of {...; _ -> ...x... }
596 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
597 -- It's quite easily done: simply extend the environment to bind the
598 -- default binder to the scrutinee.
600 tidy_deflt scrut NoDefault = returnTM NoDefault
601 tidy_deflt scrut (BindDefault bndr rhs)
602 = newId bndr $ \ bndr' ->
603 extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
604 returnTM (BindDefault bndr' rhs')
606 extend_env = case scrut of
607 Var v -> extendEnvTM bndr v
610 tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
611 returnTM (etaCoreExpr e')
617 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
619 tidyCoreArg (VarArg v)
620 = lookupId v `thenTM` \ v' ->
623 tidyCoreArg (LitArg lit)
624 = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
626 Var v -> returnTM (VarArg v)
627 Lit l -> returnTM (LitArg l)
628 other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
631 tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
633 tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
637 tidyPrimOp (CCallOp fn casm gc tys ty)
638 = mapTM tidyTy tys `thenTM` \ tys' ->
639 tidyTy ty `thenTM` \ ty' ->
640 returnTM (CCallOp fn casm gc tys' ty')
642 tidyPrimOp other_prim_op = returnTM other_prim_op
646 %************************************************************************
648 \subsection[coreToStg-lits]{Converting literals}
650 %************************************************************************
652 Literals: the NoRep kind need to be de-no-rep'd.
653 We always replace them with a simple variable, and float a suitable
654 binding out to the top level.
658 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
660 litToRep (NoRepStr s)
661 = returnTM (stringTy, rhs)
663 rhs = if (any is_NUL (_UNPK_ s))
665 then -- Must cater for NULs in literal string
666 mkGenApp (Var unpackCString2Id)
668 LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
670 else -- No NULs in the string
671 App (Var unpackCStringId) (LitArg (MachStr s))
676 If an Integer is small enough (Haskell implementations must support
677 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
678 otherwise, wrap with @litString2Integer@.
681 litToRep (NoRepInteger i integer_ty)
682 = returnTM (integer_ty, rhs)
684 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
685 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
686 | i == 2 = Var integerPlusTwoId
687 | i == (-1) = Var integerMinusOneId
689 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
691 = Prim Int2IntegerOp [LitArg (mkMachInt i)]
693 | otherwise -- Big, so start from a string
694 = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
697 litToRep (NoRepRational r rational_ty)
698 = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
699 tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
700 returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
702 (ratio_data_con, integer_ty)
703 = case (maybeAppDataTyCon rational_ty) of
704 Just (tycon, [i_ty], [con])
705 -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey)
708 _ -> (panic "ratio_data_con", panic "integer_ty")
710 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
714 funnyParallelOp SeqOp = True
715 funnyParallelOp ParOp = True
716 funnyParallelOp ForkOp = True
717 funnyParallelOp _ = False
721 %************************************************************************
723 \subsection{The monad}
725 %************************************************************************
728 type TidyM a state = Module
729 -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
733 type TopTidyM a = TidyM a Unique
734 type NestTidyM a = TidyM a (Unique, -- Global names
735 Unique, -- Local names
736 Bag CoreBinding) -- Floats
739 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
741 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
743 = case m mod env initialTopTidyUnique of
744 (result, _) -> result
746 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
747 initNestedTM m mod env global_us
748 = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
749 (result, (global_us', _, floats)) -> ((result, floats), global_us')
751 returnTM v mod env usf = (v, usf)
752 thenTM m k mod env usf = case m mod env usf of
753 (r, usf') -> k r mod env usf'
755 mapTM f [] = returnTM []
756 mapTM f (x:xs) = f x `thenTM` \ r ->
757 mapTM f xs `thenTM` \ rs ->
763 -- Need to extend the environment when we munge a binder, so that occurrences
764 -- of the binder will print the correct way (i.e. as a global not a local)
765 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
766 mungeTopBinder id thing_inside mod env us
767 = case lookupIdEnv env id of
768 Just (ValBinder global) -> thing_inside global mod env us -- Already bound
770 other -> -- Give it a new print-name unless it's an exported thing
771 -- setNameVisibility also does the local/global thing
773 (id', us') | isExported id = (id, us)
775 = (setIdVisibility (Just mod) us id,
778 new_env = addToUFM env id (ValBinder id')
780 thing_inside id' mod new_env us'
782 mungeTopBinders [] k = k []
783 mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
784 mungeTopBinders bs $ \ bs' ->
787 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
788 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
790 gus' = incrUnique gus
791 lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
792 lit_id = setIdVisibility (Just mod) gus lit_local
794 (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
796 lookupId :: Id -> TidyM Id state
797 lookupId v mod env usf
798 = case lookupUFM env v of
800 Just (ValBinder v') -> (v', usf)
802 extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
803 extendEnvTM v v' m mod env usf
804 = m mod (addOneToIdEnv env v (ValBinder v')) usf
808 Making new local binders
809 ~~~~~~~~~~~~~~~~~~~~~~~~
811 newId id thing_inside mod env (gus, local_uniq, floats)
813 -- Give the Id a fresh print-name, *and* rename its type
814 local_uniq' = incrUnique local_uniq
815 rn_id = setIdVisibility Nothing local_uniq id
816 id' = apply_to_Id (nmbr_ty env local_uniq') rn_id
817 env' = addToUFM env id (ValBinder id')
819 thing_inside id' mod env' (gus, local_uniq', floats)
821 newIds [] thing_inside
823 newIds (bndr:bndrs) thing_inside
824 = newId bndr $ \ bndr' ->
825 newIds bndrs $ \ bndrs' ->
826 thing_inside (bndr' : bndrs')
829 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
831 local_uniq' = incrUnique local_uniq
832 tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
833 env' = addToUFM env tyvar (TyBinder tyvar')
835 thing_inside tyvar' mod env' (gus, local_uniq', floats)
837 newUVar uvar thing_inside mod env (gus, local_uniq, floats)
839 local_uniq' = incrUnique local_uniq
840 uvar' = cloneUVar uvar local_uniq
841 env' = addToUFM env uvar (UsageBinder uvar')
843 thing_inside uvar' mod env' (gus, local_uniq', floats)
849 tidyTy ty mod env usf@(_, local_uniq, _)
850 = (nmbr_ty env local_uniq ty, usf)
851 -- We can use local_uniq as a base for renaming forall'd variables
852 -- in the type; we don't need to know how many are consumed.
854 -- This little impedance-matcher calls nmbrType with the right arguments
856 = nmbrType tv_env u_env uniq ty
858 tv_env :: TyVar -> TyVar
859 tv_env tyvar = case lookupUFM env tyvar of
860 Just (TyBinder tyvar') -> tyvar'
863 u_env :: UVar -> UVar
864 u_env uvar = case lookupUFM env uvar of
865 Just (UsageBinder uvar') -> uvar'