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 = mapTM tidyCoreArg args `thenTM` \ args' ->
505 returnTM (Prim prim args')
507 tidyCoreExpr (Lam (ValBinder v) body)
509 tidyCoreExpr body `thenTM` \ body' ->
510 returnTM (Lam (ValBinder v') body')
512 tidyCoreExpr (Lam (TyBinder tv) body)
513 = newTyVar tv $ \ tv' ->
514 tidyCoreExpr body `thenTM` \ body' ->
515 returnTM (Lam (TyBinder tv') body')
517 tidyCoreExpr (Lam (UsageBinder uv) body)
518 = newUVar uv $ \ uv' ->
519 tidyCoreExpr body `thenTM` \ body' ->
520 returnTM (Lam (UsageBinder uv') body')
522 -- Try for let-to-case (see notes in Simplify.lhs for why
523 -- some let-to-case stuff is deferred to now).
524 tidyCoreExpr (Let (NonRec bndr rhs) body)
525 | willBeDemanded (getIdDemandInfo bndr) &&
526 typeOkForCase (idType bndr)
527 = ASSERT( not (isPrimType (idType bndr)) )
528 tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
530 tidyCoreExpr (Let (NonRec bndr rhs) body)
531 = tidyCoreExpr rhs `thenTM` \ rhs' ->
532 newId bndr $ \ bndr' ->
533 tidyCoreExprEta body `thenTM` \ body' ->
534 returnTM (Let (NonRec bndr' rhs') body')
536 tidyCoreExpr (Let (Rec pairs) body)
537 = newIds bndrs $ \ bndrs' ->
538 mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
539 tidyCoreExprEta body `thenTM` \ body' ->
540 returnTM (Let (Rec (bndrs' `zip` rhss')) body')
542 (bndrs, rhss) = unzip pairs
544 tidyCoreExpr (SCC cc body)
545 = tidyCoreExprEta body `thenTM` \ body' ->
546 returnTM (SCC cc body')
548 tidyCoreExpr (Coerce coercion ty body)
549 = tidyCoreExprEta body `thenTM` \ body' ->
550 tidyTy ty `thenTM` \ ty' ->
551 returnTM (Coerce coercion ty' body')
553 -- Wierd case for par, seq, fork etc. See notes above.
554 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
556 = tidyCoreExpr scrut `thenTM` \ scrut' ->
557 newId binder $ \ binder' ->
558 tidyCoreExprEta rhs `thenTM` \ rhs' ->
559 returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
561 -- Eliminate polymorphic case, for which we can't generate code just yet
562 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
563 | not (typeOkForCase (idType deflt_bndr))
564 = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $
566 Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs)
567 other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
569 tidyCoreExpr (Case scrut alts)
570 = tidyCoreExpr scrut `thenTM` \ scrut' ->
571 tidy_alts scrut' alts `thenTM` \ alts' ->
572 returnTM (Case scrut' alts')
574 tidy_alts scrut (AlgAlts alts deflt)
575 = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
576 tidy_deflt scrut deflt `thenTM` \ deflt' ->
577 returnTM (AlgAlts alts' deflt')
579 tidy_alts scrut (PrimAlts alts deflt)
580 = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
581 tidy_deflt scrut deflt `thenTM` \ deflt' ->
582 returnTM (PrimAlts alts' deflt')
584 tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
585 tidyCoreExprEta rhs `thenTM` \ rhs' ->
586 returnTM (con, bndrs', rhs')
588 tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
591 -- We convert case x of {...; x' -> ...x'...}
593 -- case x of {...; _ -> ...x... }
595 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
596 -- It's quite easily done: simply extend the environment to bind the
597 -- default binder to the scrutinee.
599 tidy_deflt scrut NoDefault = returnTM NoDefault
600 tidy_deflt scrut (BindDefault bndr rhs)
601 = newId bndr $ \ bndr' ->
602 extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
603 returnTM (BindDefault bndr' rhs')
605 extend_env = case scrut of
606 Var v -> extendEnvTM bndr v
609 tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
610 returnTM (etaCoreExpr e')
616 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
618 tidyCoreArg (VarArg v)
619 = lookupId v `thenTM` \ v' ->
622 tidyCoreArg (LitArg lit)
623 = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
625 Var v -> returnTM (VarArg v)
626 Lit l -> returnTM (LitArg l)
627 other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
630 tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
632 tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
636 %************************************************************************
638 \subsection[coreToStg-lits]{Converting literals}
640 %************************************************************************
642 Literals: the NoRep kind need to be de-no-rep'd.
643 We always replace them with a simple variable, and float a suitable
644 binding out to the top level.
648 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
650 litToRep (NoRepStr s)
651 = returnTM (stringTy, rhs)
653 rhs = if (any is_NUL (_UNPK_ s))
655 then -- Must cater for NULs in literal string
656 mkGenApp (Var unpackCString2Id)
658 LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
660 else -- No NULs in the string
661 App (Var unpackCStringId) (LitArg (MachStr s))
666 If an Integer is small enough (Haskell implementations must support
667 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
668 otherwise, wrap with @litString2Integer@.
671 litToRep (NoRepInteger i integer_ty)
672 = returnTM (integer_ty, rhs)
674 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
675 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
676 | i == 2 = Var integerPlusTwoId
677 | i == (-1) = Var integerMinusOneId
679 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
681 = Prim Int2IntegerOp [LitArg (mkMachInt i)]
683 | otherwise -- Big, so start from a string
684 = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
687 litToRep (NoRepRational r rational_ty)
688 = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
689 tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
690 returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
692 (ratio_data_con, integer_ty)
693 = case (maybeAppDataTyCon rational_ty) of
694 Just (tycon, [i_ty], [con])
695 -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey)
698 _ -> (panic "ratio_data_con", panic "integer_ty")
700 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
704 funnyParallelOp SeqOp = True
705 funnyParallelOp ParOp = True
706 funnyParallelOp ForkOp = True
707 funnyParallelOp _ = False
711 %************************************************************************
713 \subsection{The monad}
715 %************************************************************************
718 type TidyM a state = Module
719 -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
723 type TopTidyM a = TidyM a Unique
724 type NestTidyM a = TidyM a (Unique, -- Global names
725 Unique, -- Local names
726 Bag CoreBinding) -- Floats
729 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
731 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
733 = case m mod env initialTopTidyUnique of
734 (result, _) -> result
736 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
737 initNestedTM m mod env global_us
738 = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
739 (result, (global_us', _, floats)) -> ((result, floats), global_us')
741 returnTM v mod env usf = (v, usf)
742 thenTM m k mod env usf = case m mod env usf of
743 (r, usf') -> k r mod env usf'
745 mapTM f [] = returnTM []
746 mapTM f (x:xs) = f x `thenTM` \ r ->
747 mapTM f xs `thenTM` \ rs ->
753 -- Need to extend the environment when we munge a binder, so that occurrences
754 -- of the binder will print the correct way (i.e. as a global not a local)
755 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
756 mungeTopBinder id thing_inside mod env us
757 = case lookupIdEnv env id of
758 Just (ValBinder global) -> thing_inside global mod env us -- Already bound
760 other -> -- Give it a new print-name unless it's an exported thing
761 -- setNameVisibility also does the local/global thing
763 (id', us') | isExported id = (id, us)
765 = (setIdVisibility (Just mod) us id,
768 new_env = addToUFM env id (ValBinder id')
770 thing_inside id' mod new_env us'
772 mungeTopBinders [] k = k []
773 mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
774 mungeTopBinders bs $ \ bs' ->
777 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
778 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
780 gus' = incrUnique gus
781 lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
782 lit_id = setIdVisibility (Just mod) gus lit_local
784 (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
786 lookupId :: Id -> TidyM Id state
787 lookupId v mod env usf
788 = case lookupUFM env v of
790 Just (ValBinder v') -> (v', usf)
792 extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
793 extendEnvTM v v' m mod env usf
794 = m mod (addOneToIdEnv env v (ValBinder v')) usf
798 Making new local binders
799 ~~~~~~~~~~~~~~~~~~~~~~~~
801 newId id thing_inside mod env (gus, local_uniq, floats)
803 -- Give the Id a fresh print-name, *and* rename its type
804 local_uniq' = incrUnique local_uniq
805 rn_id = setIdVisibility Nothing local_uniq id
806 id' = apply_to_Id (nmbr_ty env local_uniq') rn_id
807 env' = addToUFM env id (ValBinder id')
809 thing_inside id' mod env' (gus, local_uniq', floats)
811 newIds [] thing_inside
813 newIds (bndr:bndrs) thing_inside
814 = newId bndr $ \ bndr' ->
815 newIds bndrs $ \ bndrs' ->
816 thing_inside (bndr' : bndrs')
819 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
821 local_uniq' = incrUnique local_uniq
822 tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
823 env' = addToUFM env tyvar (TyBinder tyvar')
825 thing_inside tyvar' mod env' (gus, local_uniq', floats)
827 newUVar uvar thing_inside mod env (gus, local_uniq, floats)
829 local_uniq' = incrUnique local_uniq
830 uvar' = cloneUVar uvar local_uniq
831 env' = addToUFM env uvar (UsageBinder uvar')
833 thing_inside uvar' mod env' (gus, local_uniq', floats)
839 tidyTy ty mod env usf@(_, local_uniq, _)
840 = (nmbr_ty env local_uniq ty, usf)
841 -- We can use local_uniq as a base for renaming forall'd variables
842 -- in the type; we don't need to know how many are consumed.
844 -- This little impedance-matcher calls nmbrType with the right arguments
846 = nmbrType tv_env u_env uniq ty
848 tv_env :: TyVar -> TyVar
849 tv_env tyvar = case lookupUFM env tyvar of
850 Just (TyBinder tyvar') -> tyvar'
853 u_env :: UVar -> UVar
854 u_env uvar = case lookupUFM env uvar of
855 Just (UsageBinder uvar') -> uvar'