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, replacePragmaInfo, getIdDemandInfo, idType,
39 getIdInfo, getPragmaInfo,
40 nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
41 lookupIdEnv, SYN_IE(IdEnv), omitIfaceSigForId,
42 GenId{-instance Outputable-}, SYN_IE(Id)
44 import IdInfo ( willBeDemanded, DemandInfo )
45 import Name ( isExported, isLocallyDefined, SYN_IE(Module), NamedThing(..) )
46 import TyCon ( TyCon )
47 import PrimOp ( PrimOp(..) )
48 import PrelVals ( unpackCStringId, unpackCString2Id,
49 integerZeroId, integerPlusOneId,
50 integerPlusTwoId, integerMinusOneId
52 import Type ( maybeAppDataTyCon, isPrimType, SYN_IE(Type) )
53 import TysWiredIn ( stringTy )
54 import LiberateCase ( liberateCase )
55 import MagicUFs ( MagicUnfoldingFun )
56 import Outputable ( PprStyle(..), Outputable(..){-instance * (,) -} )
58 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
59 import Pretty ( Doc, vcat, ($$), hsep )
60 import SAT ( doStaticArgs )
61 import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
62 import SimplPgm ( simplifyPgm )
64 import SpecUtils ( pprSpecErrs )
65 import StrictAnal ( saWwTopBinds )
66 import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} )
67 import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-}, Uniquable(..) )
68 import UniqSupply ( splitUniqSupply, getUnique, UniqSupply )
69 import Util ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic )
70 import SrcLoc ( noSrcLoc )
71 import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
76 #ifndef OMIT_DEFORESTER
77 import Deforest ( deforestProgram )
78 import DefUtils ( deforestable )
84 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
85 -> FAST_STRING -- module name (profiling only)
86 -> PprStyle -- printing style (for debugging only)
87 -> UniqSupply -- a name supply
88 -> [TyCon] -- local data tycons and tycon specialisations
89 -> FiniteMap TyCon [(Bool, [Maybe Type])]
90 -> [CoreBinding] -- input...
92 ([CoreBinding], -- results: program, plus...
93 SpecialiseData) -- specialisation data
95 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
97 (if opt_D_verbose_core2core then
98 hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
101 -- Do the main business
102 --case (splitUniqSupply us) of { (us1,us2) ->
103 foldl_mn do_core_pass
104 (binds, us, init_specdata, zeroSimplCount)
106 >>= \ (processed_binds, us', spec_data, simpl_stats) ->
108 -- Do the final tidy-up
110 final_binds = core_linter "TidyCorePgm" True $
111 tidyCorePgm module_name us' processed_binds
115 (if opt_D_simplifier_stats then
116 hPutStr stderr ("\nSimplifier Stats:\n") >>
117 hPutStr stderr (showSimplCount simpl_stats) >>
122 return (final_binds, spec_data) --}
124 -- (us1, us2) = splitUniqSupply us
125 init_specdata = initSpecData local_tycons tycon_specs
128 core_linter what spec_done
129 = if opt_DoCoreLinting
130 then (if opt_D_show_passes then
131 trace ("\n*** Core Lint result of " ++ what)
134 lintCoreBindings ppr_style what spec_done
138 do_core_pass info@(binds, us, spec_data, simpl_stats) to_do =
140 -- (us1, us2) = splitUniqSupply us
142 case (splitUniqSupply us) of
145 CoreDoSimplify simpl_sw_chkr
146 -> _scc_ "CoreSimplify"
147 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
148 then " (foldr/build)" else "") >>
149 case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
150 (p, it_cnt, simpl_stats2)
151 -> end_pass False us2 p spec_data simpl_stats2
152 ("Simplify (" ++ show it_cnt ++ ")"
153 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
154 then " foldr/build" else "")
156 CoreDoFoldrBuildWorkerWrapper
157 -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
159 case (mkFoldrBuildWW us1 binds) of { binds2 ->
160 end_pass False us2 binds2 spec_data simpl_stats "FBWW" }
162 CoreDoFoldrBuildWWAnal
163 -> _scc_ "CoreDoFoldrBuildWWAnal"
164 begin_pass "AnalFBWW" >>
165 case (analFBWW binds) of { binds2 ->
166 end_pass False us2 binds2 spec_data simpl_stats "AnalFBWW" }
169 -> _scc_ "LiberateCase"
170 begin_pass "LiberateCase" >>
171 case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
172 end_pass False us2 binds2 spec_data simpl_stats "LiberateCase" }
175 -> _scc_ "FloatInwards"
176 begin_pass "FloatIn" >>
177 case (floatInwards binds) of { binds2 ->
178 end_pass False us2 binds2 spec_data simpl_stats "FloatIn" }
181 -> _scc_ "CoreFloating"
182 begin_pass "FloatOut" >>
183 case (floatOutwards us1 binds) of { binds2 ->
184 end_pass False us2 binds2 spec_data simpl_stats "FloatOut" }
187 -> _scc_ "CoreStaticArgs"
188 begin_pass "StaticArgs" >>
189 case (doStaticArgs binds us1) of { binds2 ->
190 end_pass False us2 binds2 spec_data simpl_stats "StaticArgs" }
191 -- Binds really should be dependency-analysed for static-
192 -- arg transformation... Not to worry, they probably are.
193 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
196 -> _scc_ "CoreStranal"
197 begin_pass "StrAnal" >>
198 case (saWwTopBinds us1 binds) of { binds2 ->
199 end_pass False us2 binds2 spec_data simpl_stats "StrAnal" }
202 -> _scc_ "Specialise"
203 begin_pass "Specialise" >>
204 case (specProgram us1 binds spec_data) of {
205 (p, spec_data2@(SpecData _ spec_noerrs _ _ _
206 spec_errs spec_warn spec_tyerrs)) ->
208 -- if we got errors, we die straight away
209 (if not spec_noerrs ||
210 (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
212 (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
213 >> hPutStr stderr "\n"
217 (if not spec_noerrs then -- Stop here if specialisation errors occured
222 end_pass False us2 p spec_data2 simpl_stats "Specialise"
227 -> error "ERROR: CoreDoDeforest: not built into compiler\n"
229 -> _scc_ "Deforestation"
230 begin_pass "Deforestation" >>
231 case (deforestProgram binds us1) of { binds2 ->
232 end_pass False us2 binds2 spec_data simpl_stats "Deforestation" }
235 CoreDoPrintCore -- print result of last pass
236 -> end_pass True us2 binds spec_data simpl_stats "Print"
238 -------------------------------------------------
241 = if opt_D_show_passes
242 then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
243 else \ what -> return ()
245 end_pass print us2 binds2
246 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
248 = -- report verbosely, if required
249 (if (opt_D_verbose_core2core && not print) ||
250 (print && not opt_D_verbose_core2core)
252 hPutStr stderr ("\n*** "++what++":\n")
255 (vcat (map (pprCoreBinding ppr_style) binds2)))
261 linted_binds = core_linter what spec_done binds2
264 (linted_binds, -- processed binds, possibly run thru CoreLint
265 us2, -- UniqueSupply for the next guy
266 spec_data2, -- possibly-updated specialisation info
267 simpl_stats2 -- accumulated simplifier stats
270 -- here so it can be inlined...
271 foldl_mn f z [] = return z
272 foldl_mn f z (x:xs) = f z x >>= \ zz ->
278 %************************************************************************
280 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
282 %************************************************************************
284 Several tasks are done by @tidyCorePgm@
286 1. Eliminate indirections. The point here is to transform
292 2. Make certain top-level bindings into Globals. The point is that
293 Global things get externally-visible labels at code generation
296 3. Make the representation of NoRep literals explicit, and
297 float their bindings to the top level
300 case x of {...; x' -> ...x'...}
302 case x of {...; _ -> ...x... }
303 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
305 5. *Mangle* cases involving fork# and par# in the discriminant. The
306 original templates for these primops (see @PrelVals.lhs@) constructed
307 case expressions with boolean results solely to fool the strictness
308 analyzer, the simplifier, and anyone else who might want to fool with
309 the evaluation order. At this point in the compiler our evaluation
310 order is safe. Therefore, we convert expressions of the form:
319 6. Eliminate polymorphic case expressions. We can't generate code for them yet.
321 7. Do eta reduction for lambda abstractions appearing in:
322 - the RHS of case alternatives
324 These will otherwise turn into local bindings during Core->STG; better to
325 nuke them if possible. (In general the simplifier does eta expansion not
326 eta reduction, up to this point.)
328 8. Do let-to-case. See notes in Simplify.lhs for why we defer let-to-case
329 for multi-constructor types.
332 Eliminate indirections
333 ~~~~~~~~~~~~~~~~~~~~~~
334 In @elimIndirections@, we look for things at the top-level of the form...
339 In cases we find like this, we go {\em backwards} and replace
340 \tr{x_local} with \tr{x_exported}. This save a gratuitous jump
341 (from \tr{x_exported} to \tr{x_local}), and makes strictness
342 information propagate better.
344 We rely on prior eta reduction to simplify things like
346 x_exported = /\ tyvars -> x_local tyvars
351 If more than one exported thing is equal to a local thing (i.e., the
352 local thing really is shared), then we do one only:
355 x_exported1 = x_local
356 x_exported2 = x_local
360 x_exported2 = x_exported1
363 There's a possibility of leaving unchanged something like this:
366 x_exported1 = x_local Int
368 By the time we've thrown away the types in STG land this
369 could be eliminated. But I don't think it's very common
370 and it's dangerous to do this fiddling in STG land
371 because we might elminate a binding that's mentioned in the
372 unfolding for something.
374 General Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
375 Then blast the whole program (LHSs as well as RHSs) with it.
380 tidyCorePgm :: Module -> UniqSupply -> [CoreBinding] -> [CoreBinding]
382 tidyCorePgm mod us binds_in
383 = initTM mod indirection_env us $
384 tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds ->
385 returnTM (bagToList binds)
387 (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
389 try_bind :: IdEnv Id -> CoreBinding -> (IdEnv Id, Maybe CoreBinding)
390 try_bind env_so_far (NonRec exported_binder rhs)
391 | isExported exported_binder && -- Only if this is exported
392 maybeToBool maybe_rhs_id && -- and the RHS is a simple Id
394 isLocallyDefined rhs_id && -- Only if this one is defined in this
395 -- module, so that we *can* change its
396 -- binding to be the exported thing!
398 not (isExported rhs_id) && -- Only if this one is not itself exported,
399 -- since the transformation will nuke it
401 not (omitIfaceSigForId rhs_id) && -- Don't do the transformation if rhs_id is
402 -- something like a constructor, whose
403 -- definition is implicitly exported and
404 -- which must not vanish.
405 -- To illustrate the preceding check consider
409 -- Here, we'll make a local, non-exported, defn for MkT, and without the
410 -- above condition we'll transform it to:
413 -- This is bad because mkT will get the IdDetails of MkT, and won't
414 -- be exported. Also the code generator won't make a definition for
415 -- the MkT constructor.
416 -- Slightly gruesome, this.
418 not (maybeToBool (lookupIdEnv env_so_far rhs_id))
419 -- Only if not already substituted for
421 = (addOneToIdEnv env_so_far rhs_id new_rhs_id, Nothing)
423 maybe_rhs_id = case etaCoreExpr rhs of
424 Var rhs_id -> Just rhs_id
426 Just rhs_id = maybe_rhs_id
427 new_rhs_id = exported_binder `replaceIdInfo` getIdInfo rhs_id
428 `replacePragmaInfo` getPragmaInfo rhs_id
429 -- NB: we keep the Pragmas and IdInfo for the old rhs_id!
430 -- This is important; it might be marked "no-inline" by
431 -- the occurrence analyser (because it's recursive), and
432 -- we must not lose that information.
434 try_bind env_so_far bind
435 = (env_so_far, Just bind)
441 tidyTopBindings [] = returnTM emptyBag
442 tidyTopBindings (b:bs)
446 tidyTopBinding :: CoreBinding
447 -> TidyM (Bag CoreBinding)
448 -> TidyM (Bag CoreBinding)
450 tidyTopBinding (NonRec bndr rhs) thing_inside
451 = getFloats (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
452 mungeTopBinder bndr $ \ bndr' ->
453 thing_inside `thenTM` \ binds ->
454 returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
456 tidyTopBinding (Rec pairs) thing_inside
457 = mungeTopBinders binders $ \ binders' ->
458 getFloats (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
459 thing_inside `thenTM` \ binds_inside ->
460 returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
462 (binders, rhss) = unzip pairs
469 tidyCoreBinding (NonRec bndr rhs)
470 = tidyCoreExpr rhs `thenTM` \ rhs' ->
471 returnTM (NonRec bndr rhs')
473 tidyCoreBinding (Rec pairs)
474 = mapTM do_one pairs `thenTM` \ pairs' ->
475 returnTM (Rec pairs')
477 do_one (bndr,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' ->
478 returnTM (bndr, rhs')
486 tidyCoreExpr (Var v) = lookupTM v `thenTM` \ v' ->
489 tidyCoreExpr (Lit lit)
490 = litToRep lit `thenTM` \ (_, lit_expr) ->
493 tidyCoreExpr (App fun arg)
494 = tidyCoreExpr fun `thenTM` \ fun' ->
495 tidyCoreArg arg `thenTM` \ arg' ->
496 returnTM (App fun' arg')
498 tidyCoreExpr (Con con args)
499 = mapTM tidyCoreArg args `thenTM` \ args' ->
500 returnTM (Con con args')
502 tidyCoreExpr (Prim prim args)
503 = mapTM tidyCoreArg args `thenTM` \ args' ->
504 returnTM (Prim prim args')
506 tidyCoreExpr (Lam bndr body)
507 = tidyCoreExpr body `thenTM` \ body' ->
508 returnTM (Lam bndr body')
510 -- Try for let-to-case (see notes in Simplify.lhs for why
511 -- some let-to-case stuff is deferred to now).
512 tidyCoreExpr (Let (NonRec bndr rhs) body)
513 | willBeDemanded (getIdDemandInfo bndr) &&
514 typeOkForCase (idType bndr)
515 = ASSERT( not (isPrimType (idType bndr)) )
516 tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
518 tidyCoreExpr (Let bind body)
519 = tidyCoreBinding bind `thenTM` \ bind' ->
520 tidyCoreExprEta body `thenTM` \ body' ->
521 returnTM (Let bind' body')
523 tidyCoreExpr (SCC cc body)
524 = tidyCoreExprEta body `thenTM` \ body' ->
525 returnTM (SCC cc body')
527 tidyCoreExpr (Coerce coercion ty body)
528 = tidyCoreExprEta body `thenTM` \ body' ->
529 returnTM (Coerce coercion ty body')
531 -- Wierd case for par, seq, fork etc. See notes above.
532 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
534 = tidyCoreExpr scrut `thenTM` \ scrut' ->
535 tidyCoreExprEta rhs `thenTM` \ rhs' ->
536 returnTM (Case scrut' (PrimAlts [] (BindDefault binder rhs')))
538 -- Eliminate polymorphic case, for which we can't generate code just yet
539 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
540 | not (typeOkForCase (idType deflt_bndr))
541 = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $
543 Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs)
544 other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
546 tidyCoreExpr (Case scrut alts)
547 = tidyCoreExpr scrut `thenTM` \ scrut' ->
548 tidy_alts scrut' alts `thenTM` \ alts' ->
549 returnTM (Case scrut' alts')
551 tidy_alts scrut (AlgAlts alts deflt)
552 = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
553 tidy_deflt scrut deflt `thenTM` \ deflt' ->
554 returnTM (AlgAlts alts' deflt')
556 tidy_alts scrut (PrimAlts alts deflt)
557 = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
558 tidy_deflt scrut deflt `thenTM` \ deflt' ->
559 returnTM (PrimAlts alts' deflt')
561 tidy_alg_alt (con,bndrs,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
562 returnTM (con,bndrs,rhs')
564 tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
567 -- We convert case x of {...; x' -> ...x'...}
569 -- case x of {...; _ -> ...x... }
571 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
572 -- It's quite easily done: simply extend the environment to bind the
573 -- default binder to the scrutinee.
575 tidy_deflt scrut NoDefault = returnTM NoDefault
576 tidy_deflt scrut (BindDefault bndr rhs)
577 = extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
578 returnTM (BindDefault bndr rhs')
580 extend_env = case scrut of
581 Var v -> extendEnvTM bndr v
584 tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
585 returnTM (etaCoreExpr e')
591 tidyCoreArg :: CoreArg -> TidyM CoreArg
593 tidyCoreArg (VarArg v)
594 = lookupTM v `thenTM` \ v' ->
597 tidyCoreArg (LitArg lit)
598 = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
600 Var v -> returnTM (VarArg v)
601 Lit l -> returnTM (LitArg l)
602 other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
605 tidyCoreArg (TyArg ty) = returnTM (TyArg ty)
606 tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
610 %************************************************************************
612 \subsection[coreToStg-lits]{Converting literals}
614 %************************************************************************
616 Literals: the NoRep kind need to be de-no-rep'd.
617 We always replace them with a simple variable, and float a suitable
618 binding out to the top level.
622 litToRep :: Literal -> TidyM (Type, CoreExpr)
624 litToRep (NoRepStr s)
625 = returnTM (stringTy, rhs)
627 rhs = if (any is_NUL (_UNPK_ s))
629 then -- Must cater for NULs in literal string
630 mkGenApp (Var unpackCString2Id)
632 LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
634 else -- No NULs in the string
635 App (Var unpackCStringId) (LitArg (MachStr s))
640 If an Integer is small enough (Haskell implementations must support
641 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
642 otherwise, wrap with @litString2Integer@.
645 litToRep (NoRepInteger i integer_ty)
646 = returnTM (integer_ty, rhs)
648 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
649 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
650 | i == 2 = Var integerPlusTwoId
651 | i == (-1) = Var integerMinusOneId
653 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
655 = Prim Int2IntegerOp [LitArg (mkMachInt i)]
657 | otherwise -- Big, so start from a string
658 = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
661 litToRep (NoRepRational r rational_ty)
662 = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
663 tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
664 returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
666 (ratio_data_con, integer_ty)
667 = case (maybeAppDataTyCon rational_ty) of
668 Just (tycon, [i_ty], [con])
669 -> ASSERT(is_integer_ty i_ty && uniqueOf tycon == ratioTyConKey)
672 _ -> (panic "ratio_data_con", panic "integer_ty")
675 = case (maybeAppDataTyCon ty) of
676 Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
679 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
683 funnyParallelOp SeqOp = True
684 funnyParallelOp ParOp = True
685 funnyParallelOp ForkOp = True
686 funnyParallelOp _ = False
690 %************************************************************************
692 \subsection{The monad}
694 %************************************************************************
697 type TidyM a = Module
699 -> (UniqSupply, Bag CoreBinding)
700 -> (a, (UniqSupply, Bag CoreBinding))
703 = case m mod env (us,emptyBag) of
704 (result, (us',floats)) -> result
706 returnTM v mod env usf = (v, usf)
707 thenTM m k mod env usf = case m mod env usf of
708 (r, usf') -> k r mod env usf'
710 mapTM f [] = returnTM []
711 mapTM f (x:xs) = f x `thenTM` \ r ->
712 mapTM f xs `thenTM` \ rs ->
718 getFloats :: TidyM a -> TidyM (a, Bag CoreBinding)
719 getFloats m mod env (us,floats)
720 = case m mod env (us,emptyBag) of
721 (r, (us',floats')) -> ((r, floats'), (us',floats))
724 -- Need to extend the environment when we munge a binder, so that occurrences
725 -- of the binder will print the correct way (i.e. as a global not a local)
726 mungeTopBinder :: Id -> (Id -> TidyM a) -> TidyM a
727 mungeTopBinder id thing_inside mod env usf
728 = case lookupIdEnv env id of
729 Just global -> thing_inside global mod env usf
730 Nothing -> thing_inside new_global mod new_env usf
732 new_env = addOneToIdEnv env id new_global
733 new_global = setIdVisibility mod id
735 mungeTopBinders [] k = k []
736 mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
737 mungeTopBinders bs $ \ bs' ->
740 addTopFloat :: Type -> CoreExpr -> TidyM Id
741 addTopFloat lit_ty lit_rhs mod env (us, floats)
742 = case splitUniqSupply us of
745 lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc
746 lit_id = setIdVisibility mod lit_local
747 --(us', us1) = splitUniqSupply us
750 (lit_id, (us', floats `snocBag` NonRec lit_id lit_rhs))
753 lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc
754 lit_id = setIdVisibility mod lit_local
755 (us', us1) = splitUniqSupply us
758 lookupTM v mod env usf
759 = case lookupIdEnv env v of
763 extendEnvTM v v' m mod env usf
764 = m mod (addOneToIdEnv env v v') usf