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,
21 opt_D_verbose_core2core,
24 opt_ReportWhyUnfoldingsDisallowed,
26 opt_LiberateCaseThreshold
28 import CoreLint ( lintCoreBindings )
30 import CoreUtils ( coreExprType )
31 import SimplUtils ( etaCoreExpr, typeOkForCase )
33 import Literal ( Literal(..), literalType, mkMachInt )
34 import ErrUtils ( ghcExit, dumpIfSet, doIfSet )
35 import FiniteMap ( FiniteMap )
36 import FloatIn ( floatInwards )
37 import FloatOut ( floatOutwards )
38 import FoldrBuildWW ( mkFoldrBuildWW )
39 import Id ( mkSysLocal, setIdVisibility, replaceIdInfo,
40 replacePragmaInfo, getIdDemandInfo, idType,
41 getIdInfo, getPragmaInfo, mkIdWithNewUniq,
42 nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
43 lookupIdEnv, SYN_IE(IdEnv), omitIfaceSigForId,
45 GenId{-instance Outputable-}, SYN_IE(Id)
47 import IdInfo ( willBeDemanded, DemandInfo )
48 import Name ( isExported, isLocallyDefined,
49 isLocalName, uniqToOccName,
50 SYN_IE(Module), NamedThing(..), OccName(..)
52 import TyCon ( TyCon )
53 import PrimOp ( PrimOp(..) )
54 import PrelVals ( unpackCStringId, unpackCString2Id,
55 integerZeroId, integerPlusOneId,
56 integerPlusTwoId, integerMinusOneId
58 import Type ( maybeAppDataTyCon, isPrimType, SYN_IE(Type) )
59 import TysWiredIn ( stringTy, isIntegerTy )
60 import LiberateCase ( liberateCase )
61 import MagicUFs ( MagicUnfoldingFun )
62 import Outputable ( pprDumpStyle, printErrs,
63 PprStyle(..), Outputable(..){-instance * (,) -}
66 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-},
69 import Pretty ( Doc, vcat, ($$), hsep )
70 import SAT ( doStaticArgs )
71 import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
72 import SimplPgm ( simplifyPgm )
74 import SpecUtils ( pprSpecErrs )
75 import StrictAnal ( saWwTopBinds )
76 import TyVar ( SYN_IE(TyVar), nullTyVarEnv, GenTyVar{-instance Eq-},
79 import Unique ( Unique{-instance Eq-}, Uniquable(..),
80 integerTyConKey, ratioTyConKey,
84 import UniqSupply ( UniqSupply, mkSplitUniqSupply,
85 splitUniqSupply, getUnique
87 import UniqFM ( UniqFM, lookupUFM, addToUFM )
88 import Usage ( SYN_IE(UVar), cloneUVar )
89 import Util ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic )
90 import SrcLoc ( noSrcLoc )
91 import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
98 core2core :: [CoreToDo] -- spec of what core-to-core passes to do
99 -> FAST_STRING -- module name (profiling only)
100 -> UniqSupply -- a name supply
101 -> [TyCon] -- local data tycons and tycon specialisations
102 -> FiniteMap TyCon [(Bool, [Maybe Type])]
103 -> [CoreBinding] -- input...
105 ([CoreBinding], -- results: program, plus...
106 SpecialiseData) -- specialisation data
108 core2core core_todos module_name us local_tycons tycon_specs binds
109 = -- Do the main business
110 foldl_mn do_core_pass
111 (binds, us, init_specdata, zeroSimplCount)
113 >>= \ (processed_binds, us', spec_data, simpl_stats) ->
115 -- Do the final tidy-up
117 final_binds = tidyCorePgm module_name processed_binds
119 lintCoreBindings "TidyCorePgm" True final_binds >>
123 dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core)
124 "Core transformations"
125 (pprCoreBindings pprDumpStyle final_binds) >>
128 doIfSet opt_D_simplifier_stats
129 (hPutStr stderr ("\nSimplifier Stats:\n") >>
130 hPutStr stderr (showSimplCount simpl_stats) >>
131 hPutStr stderr "\n") >>
134 return (final_binds, spec_data)
136 init_specdata = initSpecData local_tycons tycon_specs
139 do_core_pass info@(binds, us, spec_data, simpl_stats) to_do =
140 case (splitUniqSupply us) of
143 CoreDoSimplify simpl_sw_chkr
144 -> _scc_ "CoreSimplify"
145 begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
146 then " (foldr/build)" else "") >>
147 case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
148 (p, it_cnt, simpl_stats2)
149 -> end_pass us2 p spec_data simpl_stats2
150 ("Simplify (" ++ show it_cnt ++ ")"
151 ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
152 then " foldr/build" else "")
154 CoreDoFoldrBuildWorkerWrapper
155 -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
157 case (mkFoldrBuildWW us1 binds) of { binds2 ->
158 end_pass us2 binds2 spec_data simpl_stats "FBWW" }
160 CoreDoFoldrBuildWWAnal
161 -> _scc_ "CoreDoFoldrBuildWWAnal"
162 begin_pass "AnalFBWW" >>
163 case (analFBWW binds) of { binds2 ->
164 end_pass us2 binds2 spec_data simpl_stats "AnalFBWW" }
167 -> _scc_ "LiberateCase"
168 begin_pass "LiberateCase" >>
169 case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
170 end_pass us2 binds2 spec_data simpl_stats "LiberateCase" }
173 -> _scc_ "FloatInwards"
174 begin_pass "FloatIn" >>
175 case (floatInwards binds) of { binds2 ->
176 end_pass us2 binds2 spec_data simpl_stats "FloatIn" }
179 -> _scc_ "CoreFloating"
180 begin_pass "FloatOut" >>
181 case (floatOutwards us1 binds) of { binds2 ->
182 end_pass us2 binds2 spec_data simpl_stats "FloatOut" }
185 -> _scc_ "CoreStaticArgs"
186 begin_pass "StaticArgs" >>
187 case (doStaticArgs binds us1) of { binds2 ->
188 end_pass us2 binds2 spec_data simpl_stats "StaticArgs" }
189 -- Binds really should be dependency-analysed for static-
190 -- arg transformation... Not to worry, they probably are.
191 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
194 -> _scc_ "CoreStranal"
195 begin_pass "StrAnal" >>
196 case (saWwTopBinds us1 binds) of { binds2 ->
197 end_pass us2 binds2 spec_data simpl_stats "StrAnal" }
200 -> _scc_ "Specialise"
201 begin_pass "Specialise" >>
202 case (specProgram us1 binds spec_data) of {
203 (p, spec_data2@(SpecData _ spec_noerrs _ _ _
204 spec_errs spec_warn spec_tyerrs)) ->
206 -- if we got errors, we die straight away
207 doIfSet ((not spec_noerrs) ||
208 (opt_ShowImportSpecs && not (isEmptyBag spec_warn)))
210 (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
213 doIfSet (not spec_noerrs) -- Stop here if specialisation errors occured
216 end_pass us2 p spec_data2 simpl_stats "Specialise"
219 CoreDoPrintCore -- print result of last pass
220 -> dumpIfSet (not opt_D_verbose_core2core) "Print Core"
221 (pprCoreBindings pprDumpStyle binds) >>
222 return (binds, us1, spec_data, simpl_stats)
224 -------------------------------------------------
227 = if opt_D_show_passes
228 then hPutStr stderr ("*** Core2Core: "++what++"\n")
232 spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
234 = -- Report verbosely, if required
235 dumpIfSet opt_D_verbose_core2core what
236 (pprCoreBindings pprDumpStyle binds2) >>
238 lintCoreBindings what spec_done binds2 >>
241 (binds2, -- processed binds, possibly run thru CoreLint
242 us2, -- UniqSupply for the next guy
243 spec_data2, -- possibly-updated specialisation info
244 simpl_stats2 -- accumulated simplifier stats
248 -- here so it can be inlined...
249 foldl_mn f z [] = return z
250 foldl_mn f z (x:xs) = f z x >>= \ zz ->
256 %************************************************************************
258 \subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
260 %************************************************************************
262 Several tasks are done by @tidyCorePgm@
264 1. Eliminate indirections. The point here is to transform
270 2. Make certain top-level bindings into Globals. The point is that
271 Global things get externally-visible labels at code generation
274 3. Make the representation of NoRep literals explicit, and
275 float their bindings to the top level
278 case x of {...; x' -> ...x'...}
280 case x of {...; _ -> ...x... }
281 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
283 5. *Mangle* cases involving fork# and par# in the discriminant. The
284 original templates for these primops (see @PrelVals.lhs@) constructed
285 case expressions with boolean results solely to fool the strictness
286 analyzer, the simplifier, and anyone else who might want to fool with
287 the evaluation order. At this point in the compiler our evaluation
288 order is safe. Therefore, we convert expressions of the form:
297 6. Eliminate polymorphic case expressions. We can't generate code for them yet.
299 7. Do eta reduction for lambda abstractions appearing in:
300 - the RHS of case alternatives
302 These will otherwise turn into local bindings during Core->STG; better to
303 nuke them if possible. (In general the simplifier does eta expansion not
304 eta reduction, up to this point.)
306 8. Do let-to-case. See notes in Simplify.lhs for why we defer let-to-case
307 for multi-constructor types.
309 9. Give all binders a nice print-name. Their uniques aren't changed; rather we give
310 them lexically unique occ-names, so that we can safely print the OccNae only
311 in the interface file. [Bad idea to change the uniques, because the code
312 generator makes global labels from the uniques for local thunks etc.]
315 Eliminate indirections
316 ~~~~~~~~~~~~~~~~~~~~~~
317 In @elimIndirections@, we look for things at the top-level of the form...
322 In cases we find like this, we go {\em backwards} and replace
323 \tr{x_local} with \tr{x_exported}. This save a gratuitous jump
324 (from \tr{x_exported} to \tr{x_local}), and makes strictness
325 information propagate better.
327 We rely on prior eta reduction to simplify things like
329 x_exported = /\ tyvars -> x_local tyvars
334 If more than one exported thing is equal to a local thing (i.e., the
335 local thing really is shared), then we do one only:
338 x_exported1 = x_local
339 x_exported2 = x_local
343 x_exported2 = x_exported1
346 There's a possibility of leaving unchanged something like this:
349 x_exported1 = x_local Int
351 By the time we've thrown away the types in STG land this
352 could be eliminated. But I don't think it's very common
353 and it's dangerous to do this fiddling in STG land
354 because we might elminate a binding that's mentioned in the
355 unfolding for something.
357 General Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
358 Then blast the whole program (LHSs as well as RHSs) with it.
363 tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
365 tidyCorePgm mod binds_in
366 = initTM mod indirection_env $
367 tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds ->
368 returnTM (bagToList binds)
370 (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
372 try_bind :: IdEnv CoreBinder -> CoreBinding -> (IdEnv CoreBinder, Maybe CoreBinding)
373 try_bind env_so_far (NonRec exported_binder rhs)
374 | isExported exported_binder && -- Only if this is exported
375 maybeToBool maybe_rhs_id && -- and the RHS is a simple Id
377 isLocallyDefined rhs_id && -- Only if this one is defined in this
378 -- module, so that we *can* change its
379 -- binding to be the exported thing!
381 not (isExported rhs_id) && -- Only if this one is not itself exported,
382 -- since the transformation will nuke it
384 not (omitIfaceSigForId rhs_id) && -- Don't do the transformation if rhs_id is
385 -- something like a constructor, whose
386 -- definition is implicitly exported and
387 -- which must not vanish.
388 -- To illustrate the preceding check consider
392 -- Here, we'll make a local, non-exported, defn for MkT, and without the
393 -- above condition we'll transform it to:
396 -- This is bad because mkT will get the IdDetails of MkT, and won't
397 -- be exported. Also the code generator won't make a definition for
398 -- the MkT constructor.
399 -- Slightly gruesome, this.
401 not (maybeToBool (lookupIdEnv env_so_far rhs_id))
402 -- Only if not already substituted for
404 = (addOneToIdEnv env_so_far rhs_id (ValBinder new_rhs_id), Nothing)
406 maybe_rhs_id = case etaCoreExpr rhs of
407 Var rhs_id -> Just rhs_id
409 Just rhs_id = maybe_rhs_id
410 new_rhs_id = exported_binder `replaceIdInfo` getIdInfo rhs_id
411 `replacePragmaInfo` getPragmaInfo rhs_id
412 -- NB: we keep the Pragmas and IdInfo for the old rhs_id!
413 -- This is important; it might be marked "no-inline" by
414 -- the occurrence analyser (because it's recursive), and
415 -- we must not lose that information.
417 try_bind env_so_far bind
418 = (env_so_far, Just bind)
424 tidyTopBindings [] = returnTM emptyBag
425 tidyTopBindings (b:bs)
429 tidyTopBinding :: CoreBinding
430 -> TopTidyM (Bag CoreBinding)
431 -> TopTidyM (Bag CoreBinding)
433 tidyTopBinding (NonRec bndr rhs) thing_inside
434 = initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
435 mungeTopBinder bndr $ \ bndr' ->
436 thing_inside `thenTM` \ binds ->
437 returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
439 tidyTopBinding (Rec pairs) thing_inside
440 = mungeTopBinders binders $ \ binders' ->
441 initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
442 thing_inside `thenTM` \ binds_inside ->
443 returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
445 (binders, rhss) = unzip pairs
453 tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
456 tidyCoreExpr (Lit lit)
457 = litToRep lit `thenTM` \ (_, lit_expr) ->
460 tidyCoreExpr (App fun arg)
461 = tidyCoreExpr fun `thenTM` \ fun' ->
462 tidyCoreArg arg `thenTM` \ arg' ->
463 returnTM (App fun' arg')
465 tidyCoreExpr (Con con args)
466 = mapTM tidyCoreArg args `thenTM` \ args' ->
467 returnTM (Con con args')
469 tidyCoreExpr (Prim prim args)
470 = tidyPrimOp prim `thenTM` \ prim' ->
471 mapTM tidyCoreArg args `thenTM` \ args' ->
472 returnTM (Prim prim' args')
474 tidyCoreExpr (Lam (ValBinder v) body)
476 tidyCoreExpr body `thenTM` \ body' ->
477 returnTM (Lam (ValBinder v') body')
479 tidyCoreExpr (Lam (TyBinder tv) body)
480 = newTyVar tv $ \ tv' ->
481 tidyCoreExpr body `thenTM` \ body' ->
482 returnTM (Lam (TyBinder tv') body')
484 tidyCoreExpr (Lam (UsageBinder uv) body)
485 = newUVar uv $ \ uv' ->
486 tidyCoreExpr body `thenTM` \ body' ->
487 returnTM (Lam (UsageBinder uv') body')
489 -- Try for let-to-case (see notes in Simplify.lhs for why
490 -- some let-to-case stuff is deferred to now).
491 tidyCoreExpr (Let (NonRec bndr rhs) body)
492 | willBeDemanded (getIdDemandInfo bndr) &&
493 typeOkForCase (idType bndr)
494 = ASSERT( not (isPrimType (idType bndr)) )
495 tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
497 tidyCoreExpr (Let (NonRec bndr rhs) body)
498 = tidyCoreExpr rhs `thenTM` \ rhs' ->
499 newId bndr $ \ bndr' ->
500 tidyCoreExprEta body `thenTM` \ body' ->
501 returnTM (Let (NonRec bndr' rhs') body')
503 tidyCoreExpr (Let (Rec pairs) body)
504 = newIds bndrs $ \ bndrs' ->
505 mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
506 tidyCoreExprEta body `thenTM` \ body' ->
507 returnTM (Let (Rec (bndrs' `zip` rhss')) body')
509 (bndrs, rhss) = unzip pairs
511 tidyCoreExpr (SCC cc body)
512 = tidyCoreExprEta body `thenTM` \ body' ->
513 returnTM (SCC cc body')
515 tidyCoreExpr (Coerce coercion ty body)
516 = tidyCoreExprEta body `thenTM` \ body' ->
517 tidyTy ty `thenTM` \ ty' ->
518 returnTM (Coerce coercion ty' body')
520 -- Wierd case for par, seq, fork etc. See notes above.
521 tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
523 = tidyCoreExpr scrut `thenTM` \ scrut' ->
524 newId binder $ \ binder' ->
525 tidyCoreExprEta rhs `thenTM` \ rhs' ->
526 returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
528 -- Eliminate polymorphic case, for which we can't generate code just yet
529 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
530 | not (typeOkForCase (idType deflt_bndr))
531 = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $
533 Var v -> lookupId v `thenTM` \ v' ->
534 extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
535 other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
537 tidyCoreExpr (Case scrut alts)
538 = tidyCoreExpr scrut `thenTM` \ scrut' ->
539 tidy_alts scrut' alts `thenTM` \ alts' ->
540 returnTM (Case scrut' alts')
542 tidy_alts scrut (AlgAlts alts deflt)
543 = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
544 tidy_deflt scrut deflt `thenTM` \ deflt' ->
545 returnTM (AlgAlts alts' deflt')
547 tidy_alts scrut (PrimAlts alts deflt)
548 = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
549 tidy_deflt scrut deflt `thenTM` \ deflt' ->
550 returnTM (PrimAlts alts' deflt')
552 tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
553 tidyCoreExprEta rhs `thenTM` \ rhs' ->
554 returnTM (con, bndrs', rhs')
556 tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
559 -- We convert case x of {...; x' -> ...x'...}
561 -- case x of {...; _ -> ...x... }
563 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
564 -- It's quite easily done: simply extend the environment to bind the
565 -- default binder to the scrutinee.
567 tidy_deflt scrut NoDefault = returnTM NoDefault
568 tidy_deflt scrut (BindDefault bndr rhs)
569 = newId bndr $ \ bndr' ->
570 extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
571 returnTM (BindDefault bndr' rhs')
573 extend_env = case scrut of
574 Var v -> extendEnvTM bndr v
577 tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
578 returnTM (etaCoreExpr e')
584 tidyCoreArg :: CoreArg -> NestTidyM CoreArg
586 tidyCoreArg (VarArg v)
587 = lookupId v `thenTM` \ v' ->
590 tidyCoreArg (LitArg lit)
591 = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
593 Var v -> returnTM (VarArg v)
594 Lit l -> returnTM (LitArg l)
595 other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
598 tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
600 tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
604 tidyPrimOp (CCallOp fn casm gc tys ty)
605 = mapTM tidyTy tys `thenTM` \ tys' ->
606 tidyTy ty `thenTM` \ ty' ->
607 returnTM (CCallOp fn casm gc tys' ty')
609 tidyPrimOp other_prim_op = returnTM other_prim_op
613 %************************************************************************
615 \subsection[coreToStg-lits]{Converting literals}
617 %************************************************************************
619 Literals: the NoRep kind need to be de-no-rep'd.
620 We always replace them with a simple variable, and float a suitable
621 binding out to the top level.
625 litToRep :: Literal -> NestTidyM (Type, CoreExpr)
627 litToRep (NoRepStr s)
628 = returnTM (stringTy, rhs)
630 rhs = if (any is_NUL (_UNPK_ s))
632 then -- Must cater for NULs in literal string
633 mkGenApp (Var unpackCString2Id)
635 LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
637 else -- No NULs in the string
638 App (Var unpackCStringId) (LitArg (MachStr s))
643 If an Integer is small enough (Haskell implementations must support
644 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
645 otherwise, wrap with @litString2Integer@.
648 litToRep (NoRepInteger i integer_ty)
649 = returnTM (integer_ty, rhs)
651 rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
652 | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
653 | i == 2 = Var integerPlusTwoId
654 | i == (-1) = Var integerMinusOneId
656 | i > tARGET_MIN_INT && -- Small enough, so start from an Int
658 = Prim Int2IntegerOp [LitArg (mkMachInt i)]
660 | otherwise -- Big, so start from a string
661 = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
664 litToRep (NoRepRational r rational_ty)
665 = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
666 tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
667 returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
669 (ratio_data_con, integer_ty)
670 = case (maybeAppDataTyCon rational_ty) of
671 Just (tycon, [i_ty], [con])
672 -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey)
675 _ -> (panic "ratio_data_con", panic "integer_ty")
677 litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
681 funnyParallelOp SeqOp = True
682 funnyParallelOp ParOp = True
683 funnyParallelOp ForkOp = True
684 funnyParallelOp _ = False
688 %************************************************************************
690 \subsection{The monad}
692 %************************************************************************
695 type TidyM a state = Module
696 -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
700 type TopTidyM a = TidyM a Unique
701 type NestTidyM a = TidyM a (Unique, -- Global names
702 Unique, -- Local names
703 Bag CoreBinding) -- Floats
706 (initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
708 initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
710 = case m mod env initialTopTidyUnique of
711 (result, _) -> result
713 initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
714 initNestedTM m mod env global_us
715 = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
716 (result, (global_us', _, floats)) -> ((result, floats), global_us')
718 returnTM v mod env usf = (v, usf)
719 thenTM m k mod env usf = case m mod env usf of
720 (r, usf') -> k r mod env usf'
722 mapTM f [] = returnTM []
723 mapTM f (x:xs) = f x `thenTM` \ r ->
724 mapTM f xs `thenTM` \ rs ->
730 -- Need to extend the environment when we munge a binder, so that occurrences
731 -- of the binder will print the correct way (i.e. as a global not a local)
732 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
733 mungeTopBinder id thing_inside mod env us
734 = case lookupIdEnv env id of
735 Just (ValBinder global) -> thing_inside global mod env us -- Already bound
737 other -> -- Give it a new print-name unless it's an exported thing
738 -- setNameVisibility also does the local/global thing
740 (id', us') | isExported id = (id, us)
742 = (setIdVisibility (Just mod) us id,
745 new_env = addToUFM env id (ValBinder id')
747 thing_inside id' mod new_env us'
749 mungeTopBinders [] k = k []
750 mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
751 mungeTopBinders bs $ \ bs' ->
754 addTopFloat :: Type -> CoreExpr -> NestTidyM Id
755 addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
757 gus' = incrUnique gus
758 lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
759 lit_id = setIdVisibility (Just mod) gus lit_local
761 (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
763 lookupId :: Id -> TidyM Id state
764 lookupId v mod env usf
765 = case lookupUFM env v of
767 Just (ValBinder v') -> (v', usf)
769 extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
770 extendEnvTM v v' m mod env usf
771 = m mod (addOneToIdEnv env v (ValBinder v')) usf
775 Making new local binders
776 ~~~~~~~~~~~~~~~~~~~~~~~~
778 newId id thing_inside mod env (gus, local_uniq, floats)
780 -- Give the Id a fresh print-name, *and* rename its type
781 local_uniq' = incrUnique local_uniq
782 rn_id = setIdVisibility Nothing local_uniq id
783 id' = apply_to_Id (nmbr_ty env local_uniq') rn_id
784 env' = addToUFM env id (ValBinder id')
786 thing_inside id' mod env' (gus, local_uniq', floats)
788 newIds [] thing_inside
790 newIds (bndr:bndrs) thing_inside
791 = newId bndr $ \ bndr' ->
792 newIds bndrs $ \ bndrs' ->
793 thing_inside (bndr' : bndrs')
796 newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
798 local_uniq' = incrUnique local_uniq
799 tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
800 env' = addToUFM env tyvar (TyBinder tyvar')
802 thing_inside tyvar' mod env' (gus, local_uniq', floats)
804 newUVar uvar thing_inside mod env (gus, local_uniq, floats)
806 local_uniq' = incrUnique local_uniq
807 uvar' = cloneUVar uvar local_uniq
808 env' = addToUFM env uvar (UsageBinder uvar')
810 thing_inside uvar' mod env' (gus, local_uniq', floats)
816 tidyTy ty mod env usf@(_, local_uniq, _)
817 = (nmbr_ty env local_uniq ty, usf)
818 -- We can use local_uniq as a base for renaming forall'd variables
819 -- in the type; we don't need to know how many are consumed.
821 -- This little impedance-matcher calls nmbrType with the right arguments
823 = nmbrType tv_env u_env uniq ty
825 tv_env :: TyVar -> TyVar
826 tv_env tyvar = case lookupUFM env tyvar of
827 Just (TyBinder tyvar') -> tyvar'
830 u_env :: UVar -> UVar
831 u_env uvar = case lookupUFM env uvar of
832 Just (UsageBinder uvar') -> uvar'