2 % (c) The University of Glasgow, 1994-2000
4 \section{Core pass to saturate constructors and PrimOps}
8 corePrepPgm, corePrepExpr
11 #include "HsVersions.h"
13 import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
14 import CoreFVs ( exprFreeVars )
15 import CoreLint ( endPass )
17 import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
18 isUnLiftedType, isUnboxedTupleType, repType,
19 uaUTy, usOnce, usMany, eqUsage, seqType )
20 import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
21 import PrimOp ( PrimOp(..) )
22 import Var ( Var, Id, setVarUnique )
25 import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
26 setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
27 hasNoBinding, idNewStrictness, setIdArity
29 import HscTypes ( ModDetails(..) )
30 import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel,
41 -- ---------------------------------------------------------------------------
43 -- ---------------------------------------------------------------------------
45 The goal of this pass is to prepare for code generation.
47 1. Saturate constructor and primop applications.
49 2. Convert to A-normal form:
51 * Use case for strict arguments:
52 f E ==> case E of x -> f x
55 * Use let for non-trivial lazy arguments
56 f E ==> let x = E in f x
57 (were f is lazy and x is non-trivial)
59 3. Similarly, convert any unboxed lets into cases.
60 [I'm experimenting with leaving 'ok-for-speculation'
61 rhss in let-form right up to this point.]
63 4. Ensure that lambdas only occur as the RHS of a binding
64 (The code generator can't deal with anything else.)
66 5. Do the seq/par munging. See notes with mkCase below.
68 6. Clone all local Ids. This means that Tidy Core has the property
69 that all Ids are unique, rather than the weaker guarantee of
70 no clashes which the simplifier provides.
72 7. Give each dynamic CCall occurrence a fresh unique; this is
73 rather like the cloning step above.
75 This is all done modulo type applications and abstractions, so that
76 when type erasure is done for conversion to STG, we don't end up with
77 any trivial or useless bindings.
82 -- -----------------------------------------------------------------------------
84 -- -----------------------------------------------------------------------------
87 corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
88 corePrepPgm dflags mod_details
89 = do showPass dflags "CorePrep"
90 us <- mkSplitUniqSupply 's'
92 let floats = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
93 new_binds = foldrOL get [] floats
94 get (FloatLet b) bs = b:bs
95 get b bs = pprPanic "corePrepPgm" (ppr b)
97 endPass dflags "CorePrep" Opt_D_dump_prep new_binds
98 return (mod_details { md_binds = new_binds })
100 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
101 corePrepExpr dflags expr
102 = do showPass dflags "CorePrep"
103 us <- mkSplitUniqSupply 's'
104 let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
105 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
109 -- ---------------------------------------------------------------------------
110 -- Dealing with bindings
111 -- ---------------------------------------------------------------------------
113 data FloatingBind = FloatLet CoreBind
114 | FloatCase Id CoreExpr Bool
115 -- The bool indicates "ok-for-speculation"
117 instance Outputable FloatingBind where
118 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
119 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
121 type CloneEnv = IdEnv Id -- Clone local Ids
123 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
124 allLazy top_lvl is_rec floats
125 = foldrOL check True floats
127 unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
129 check (FloatLet _) y = y
130 check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
131 -- The ok-for-speculation flag says that it's safe to
132 -- float this Case out of a let, and thereby do it more eagerly
133 -- We need the top-level flag because it's never ok to float
134 -- an unboxed binding to the top level
136 -- ---------------------------------------------------------------------------
138 -- ---------------------------------------------------------------------------
140 corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind)
141 corePrepTopBinds env [] = returnUs nilOL
143 corePrepTopBinds env (bind : binds)
144 = corePrepTopBind env bind `thenUs` \ (env', bind') ->
145 corePrepTopBinds env' binds `thenUs` \ binds' ->
146 returnUs (bind' `appOL` binds')
148 -- NB: we do need to float out of top-level bindings
149 -- Consider x = length [True,False]
155 -- We return a *list* of bindings, because we may start with
157 -- where x is demanded, in which case we want to finish with
160 -- And then x will actually end up case-bound
162 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
163 corePrepTopBind env (NonRec bndr rhs)
164 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
165 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
166 returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
168 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
170 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
171 -- This one is used for *local* bindings
172 corePrepBind env (NonRec bndr rhs)
173 = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
174 cloneBndr env bndr `thenUs` \ (env', bndr') ->
175 mkLocalNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
176 returnUs (env', floats')
178 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
180 --------------------------------
181 corePrepRecPairs :: TopLevelFlag -> CloneEnv
182 -> [(Id,CoreExpr)] -- Recursive bindings
183 -> UniqSM (CloneEnv, OrdList FloatingBind)
184 -- Used for all recursive bindings, top level and otherwise
185 corePrepRecPairs lvl env pairs
186 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
187 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
188 returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
190 -- Flatten all the floats, and the currrent
191 -- group into a single giant Rec
192 flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
194 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
195 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
197 --------------------------------
198 corePrepRhs :: TopLevelFlag -> RecFlag
199 -> CloneEnv -> (Id, CoreExpr)
200 -> UniqSM (OrdList FloatingBind, CoreExpr)
201 -- Used for top-level bindings, and local recursive bindings
202 corePrepRhs top_lvl is_rec env (bndr, rhs)
203 = corePrepExprFloat env rhs `thenUs` \ floats_w_rhs ->
204 floatRhs top_lvl is_rec bndr floats_w_rhs
207 -- ---------------------------------------------------------------------------
208 -- Making arguments atomic (function args & constructor args)
209 -- ---------------------------------------------------------------------------
211 -- This is where we arrange that a non-trivial argument is let-bound
212 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
213 -> UniqSM (OrdList FloatingBind, CoreArg)
214 corePrepArg env arg dem
215 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
216 if no_binding_needed arg'
217 then returnUs (floats, arg')
218 else newVar (exprType arg') (exprArity arg') `thenUs` \ v ->
219 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
220 returnUs (floats', Var v)
222 no_binding_needed | opt_RuntimeTypes = exprIsAtom
223 | otherwise = exprIsTrivial
225 -- version that doesn't consider an scc annotation to be trivial.
226 exprIsTrivial (Var v)
227 | hasNoBinding v = idArity v == 0
229 exprIsTrivial (Type _) = True
230 exprIsTrivial (Lit lit) = True
231 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
232 exprIsTrivial (Note (SCC _) e) = False
233 exprIsTrivial (Note _ e) = exprIsTrivial e
234 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
235 exprIsTrivial other = False
237 -- ---------------------------------------------------------------------------
238 -- Dealing with expressions
239 -- ---------------------------------------------------------------------------
241 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
242 corePrepAnExpr env expr
243 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
247 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
251 -- e = let bs in e' (semantically, that is!)
254 -- f (g x) ===> ([v = g x], f v)
256 corePrepExprFloat env (Var v)
257 = fiddleCCall v `thenUs` \ v1 ->
258 let v2 = lookupVarEnv env v1 `orElse` v1 in
259 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
260 returnUs (nilOL, app)
262 corePrepExprFloat env expr@(Type _)
263 = returnUs (nilOL, expr)
265 corePrepExprFloat env expr@(Lit lit)
266 = returnUs (nilOL, expr)
268 corePrepExprFloat env (Let bind body)
269 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
270 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
271 returnUs (new_binds `appOL` floats, new_body)
273 corePrepExprFloat env (Note n@(SCC _) expr)
274 = corePrepAnExpr env expr `thenUs` \ expr1 ->
275 deLam expr1 `thenUs` \ expr2 ->
276 returnUs (nilOL, Note n expr2)
278 corePrepExprFloat env (Note other_note expr)
279 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
280 returnUs (floats, Note other_note expr')
282 corePrepExprFloat env expr@(Lam _ _)
283 = corePrepAnExpr env body `thenUs` \ body' ->
284 returnUs (nilOL, mkLams bndrs body')
286 (bndrs,body) = collectBinders expr
288 corePrepExprFloat env (Case scrut bndr alts)
289 = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
290 cloneBndr env bndr `thenUs` \ (env', bndr') ->
291 mapUs (sat_alt env') alts `thenUs` \ alts' ->
292 returnUs (floats, mkCase scrut' bndr' alts')
294 sat_alt env (con, bs, rhs)
295 = cloneBndrs env bs `thenUs` \ (env', bs') ->
296 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
297 deLam rhs1 `thenUs` \ rhs2 ->
298 returnUs (con, bs', rhs2)
300 corePrepExprFloat env expr@(App _ _)
301 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
302 ASSERT(null ss) -- make sure we used all the strictness info
304 -- Now deal with the function
306 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
307 returnUs (floats, app')
309 _other -> returnUs (floats, app)
313 -- Deconstruct and rebuild the application, floating any non-atomic
314 -- arguments to the outside. We collect the type of the expression,
315 -- the head of the application, and the number of actual value arguments,
316 -- all of which are used to possibly saturate this application if it
317 -- has a constructor or primop at the head.
321 -> Int -- current app depth
322 -> UniqSM (CoreExpr, -- the rebuilt expression
323 (CoreExpr,Int), -- the head of the application,
324 -- and no. of args it was applied to
325 Type, -- type of the whole expr
326 OrdList FloatingBind, -- any floats we pulled out
327 [Demand]) -- remaining argument demands
329 collect_args (App fun arg@(Type arg_ty)) depth
330 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
331 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
333 collect_args (App fun arg) depth
334 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
336 (ss1, ss_rest) = case ss of
337 (ss1:ss_rest) -> (ss1, ss_rest)
339 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
340 splitFunTy_maybe fun_ty
342 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
343 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
345 collect_args (Var v) depth
346 = fiddleCCall v `thenUs` \ v1 ->
347 let v2 = lookupVarEnv env v1 `orElse` v1 in
348 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
350 stricts = case idNewStrictness v of
351 StrictSig (DmdType _ demands _)
352 | depth >= length demands -> demands
354 -- If depth < length demands, then we have too few args to
355 -- satisfy strictness info so we have to ignore all the
356 -- strictness info, e.g. + (error "urk")
357 -- Here, we can't evaluate the arg strictly, because this
358 -- partial application might be seq'd
361 collect_args (Note (Coerce ty1 ty2) fun) depth
362 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
363 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
365 collect_args (Note note fun) depth
367 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
368 returnUs (Note note fun', hd, fun_ty, floats, ss)
370 -- non-variable fun, better let-bind it
371 collect_args fun depth
372 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
373 newVar ty (exprArity fun') `thenUs` \ fn_id ->
374 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
375 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
379 ignore_note InlineCall = True
380 ignore_note InlineMe = True
381 ignore_note _other = False
382 -- we don't ignore SCCs, since they require some code generation
384 ------------------------------------------------------------------------------
385 -- Building the saturated syntax
386 -- ---------------------------------------------------------------------------
388 -- maybeSaturate deals with saturating primops and constructors
389 -- The type is the type of the entire application
390 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
391 maybeSaturate fn expr n_args ty
392 | hasNoBinding fn = saturate_it
393 | otherwise = returnUs expr
395 fn_arity = idArity fn
396 excess_arity = fn_arity - n_args
397 saturate_it = getUniquesUs `thenUs` \ us ->
398 returnUs (etaExpand excess_arity us expr ty)
400 -- ---------------------------------------------------------------------------
401 -- Precipitating the floating bindings
402 -- ---------------------------------------------------------------------------
404 floatRhs :: TopLevelFlag -> RecFlag
406 -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
407 -> UniqSM (OrdList FloatingBind, -- Floats out of this bind
408 CoreExpr) -- Final Rhs
410 floatRhs top_lvl is_rec bndr (floats, rhs)
411 | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
412 allLazy top_lvl is_rec floats -- at top level
413 = -- Why the test for allLazy?
414 -- v = f (x `divInt#` y)
415 -- we don't want to float the case, even if f has arity 2,
416 -- because floating the case would make it evaluated too early
418 -- Finally, eta-expand the RHS, for the benefit of the code gen
419 etaExpandRhs bndr rhs `thenUs` \ rhs' ->
420 returnUs (floats, rhs')
423 -- Don't float; the RHS isn't a value
424 = mkBinds floats rhs `thenUs` \ rhs' ->
425 etaExpandRhs bndr rhs' `thenUs` \ rhs'' ->
426 returnUs (nilOL, rhs'')
428 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
429 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
430 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
431 -> UniqSM (OrdList FloatingBind)
433 mkLocalNonRec bndr dem floats rhs
434 | isUnLiftedType (idType bndr) || isStrict dem
435 -- It's a strict let, or the binder is unlifted,
436 -- so we definitely float all the bindings
437 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
438 let -- Don't make a case for a value binding,
439 -- even if it's strict. Otherwise we get
440 -- case (\x -> e) of ...!
441 float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
442 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
444 returnUs (floats `snocOL` float)
447 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
448 returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
450 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
452 | isNilOL binds = returnUs body
453 | otherwise = deLam body `thenUs` \ body' ->
454 returnUs (foldrOL mk_bind body' binds)
456 mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
457 mk_bind (FloatLet bind) body = Let bind body
459 etaExpandRhs bndr rhs
460 = -- Eta expand to match the arity claimed by the binder
461 -- Remember, after CorePrep we must not change arity
463 -- Eta expansion might not have happened already,
464 -- because it is done by the simplifier only when
465 -- there at least one lambda already.
467 -- NB1:we could refrain when the RHS is trivial (which can happen
468 -- for exported things). This would reduce the amount of code
469 -- generated (a little) and make things a little words for
470 -- code compiled without -O. The case in point is data constructor
473 -- NB2: we have to be careful that the result of etaExpand doesn't
474 -- invalidate any of the assumptions that CorePrep is attempting
475 -- to establish. One possible cause is eta expanding inside of
476 -- an SCC note - we're now careful in etaExpand to make sure the
477 -- SCC is pushed inside any new lambdas that are generated.
479 getUniquesUs `thenUs` \ us ->
480 returnUs (etaExpand (idArity bndr) us rhs (idType bndr))
482 -- ---------------------------------------------------------------------------
483 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
484 -- We arrange that they only show up as the RHS of a let(rec)
485 -- ---------------------------------------------------------------------------
487 deLam :: CoreExpr -> UniqSM CoreExpr
488 -- Remove top level lambdas by let-bindinig
491 = -- You can get things like
492 -- case e of { p -> coerce t (\s -> ...) }
493 deLam expr `thenUs` \ expr' ->
494 returnUs (Note n expr')
497 | null bndrs = returnUs expr
499 = case tryEta bndrs body of
500 Just no_lam_result -> returnUs no_lam_result
501 Nothing -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn ->
502 returnUs (Let (NonRec fn expr) (Var fn))
504 (bndrs,body) = collectBinders expr
506 -- Why try eta reduction? Hasn't the simplifier already done eta?
507 -- But the simplifier only eta reduces if that leaves something
508 -- trivial (like f, or f Int). But for deLam it would be enough to
509 -- get to a partial application, like (map f).
511 tryEta bndrs expr@(App _ _)
512 | ok_to_eta_reduce f &&
514 and (zipWith ok bndrs last_args) &&
515 not (any (`elemVarSet` fvs_remaining) bndrs)
516 = Just remaining_expr
518 (f, args) = collectArgs expr
519 remaining_expr = mkApps f remaining_args
520 fvs_remaining = exprFreeVars remaining_expr
521 (remaining_args, last_args) = splitAt n_remaining args
522 n_remaining = length args - length bndrs
524 ok bndr (Var arg) = bndr == arg
525 ok bndr other = False
527 -- we can't eta reduce something which must be saturated.
528 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
529 ok_to_eta_reduce _ = False --safe. ToDo: generalise
531 tryEta bndrs (Let bind@(NonRec b r) body)
532 | not (any (`elemVarSet` fvs) bndrs)
533 = case tryEta bndrs body of
534 Just e -> Just (Let bind e)
539 tryEta bndrs _ = Nothing
543 -- -----------------------------------------------------------------------------
544 -- Do the seq and par transformation
545 -- -----------------------------------------------------------------------------
547 Here we do two pre-codegen transformations:
553 case a of { DEFAULT -> rhs }
563 NB: seq# :: a -> Int# -- Evaluate value and return anything
564 par# :: a -> Int# -- Spark value and return anything
566 These transformations can't be done earlier, or else we might
567 think that the expression was strict in the variables in which
568 rhs is strict --- but that would defeat the purpose of seq and par.
572 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
573 -- DEFAULT alt is always first
574 = case isPrimOpId_maybe fn of
575 Just ParOp -> Case scrut bndr [deflt_alt]
576 Just SeqOp -> Case arg new_bndr [deflt_alt]
577 other -> Case scrut bndr alts
579 -- The binder shouldn't be used in the expression!
580 new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
581 setIdType bndr (exprType arg)
582 -- NB: SeqOp :: forall a. a -> Int#
583 -- So bndr has type Int#
584 -- But now we are going to scrutinise the SeqOp's argument directly,
585 -- so we must change the type of the case binder to match that
586 -- of the argument expression e.
588 mkCase scrut bndr alts = Case scrut bndr alts
592 -- -----------------------------------------------------------------------------
594 -- -----------------------------------------------------------------------------
598 = RhsDemand { isStrict :: Bool, -- True => used at least once
599 isOnceDem :: Bool -- True => used at most once
602 mkDem :: Demand -> Bool -> RhsDemand
603 mkDem strict once = RhsDemand (isStrictDmd strict) once
605 mkDemTy :: Demand -> Type -> RhsDemand
606 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
608 isOnceTy :: Type -> Bool
612 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
617 once | u `eqUsage` usOnce = True
618 | u `eqUsage` usMany = False
619 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
621 bdrDem :: Id -> RhsDemand
622 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
624 safeDem, onceDem :: RhsDemand
625 safeDem = RhsDemand False False -- always safe to use this
626 onceDem = RhsDemand False True -- used at most once
632 %************************************************************************
636 %************************************************************************
639 ------------------------------------------------------------------------------
641 -- ---------------------------------------------------------------------------
643 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
644 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
646 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
648 | isGlobalId bndr -- Top level things, which we don't want
649 = returnUs (env, bndr) -- to clone, have become GlobalIds by now
652 = getUniqueUs `thenUs` \ uniq ->
654 bndr' = setVarUnique bndr uniq
656 returnUs (extendVarEnv env bndr bndr', bndr')
658 ------------------------------------------------------------------------------
659 -- Cloning ccall Ids; each must have a unique name,
660 -- to give the code generator a handle to hang it on
661 -- ---------------------------------------------------------------------------
663 fiddleCCall :: Id -> UniqSM Id
665 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
666 returnUs (id `setVarUnique` uniq)
667 | otherwise = returnUs id
669 ------------------------------------------------------------------------------
670 -- Generating new binders
671 -- ---------------------------------------------------------------------------
673 newVar :: Type -> Arity -> UniqSM Id
674 -- We're creating a new let binder, and we must give
675 -- it the right arity for the benefit of the code generator.
678 getUniqueUs `thenUs` \ uniq ->
679 returnUs (mkSysLocal SLIT("sat") uniq ty