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 )
39 -- ---------------------------------------------------------------------------
41 -- ---------------------------------------------------------------------------
43 The goal of this pass is to prepare for code generation.
45 1. Saturate constructor and primop applications.
47 2. Convert to A-normal form:
49 * Use case for strict arguments:
50 f E ==> case E of x -> f x
53 * Use let for non-trivial lazy arguments
54 f E ==> let x = E in f x
55 (were f is lazy and x is non-trivial)
57 3. Similarly, convert any unboxed lets into cases.
58 [I'm experimenting with leaving 'ok-for-speculation'
59 rhss in let-form right up to this point.]
61 4. Ensure that lambdas only occur as the RHS of a binding
62 (The code generator can't deal with anything else.)
64 5. Do the seq/par munging. See notes with mkCase below.
66 6. Clone all local Ids. This means that Tidy Core has the property
67 that all Ids are unique, rather than the weaker guarantee of
68 no clashes which the simplifier provides.
70 7. Give each dynamic CCall occurrence a fresh unique; this is
71 rather like the cloning step above.
73 This is all done modulo type applications and abstractions, so that
74 when type erasure is done for conversion to STG, we don't end up with
75 any trivial or useless bindings.
80 -- -----------------------------------------------------------------------------
82 -- -----------------------------------------------------------------------------
85 corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
86 corePrepPgm dflags mod_details
87 = do showPass dflags "CorePrep"
88 us <- mkSplitUniqSupply 's'
90 let floats = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
91 new_binds = foldrOL get [] floats
92 get (FloatLet b) bs = b:bs
93 get b bs = pprPanic "corePrepPgm" (ppr b)
95 endPass dflags "CorePrep" Opt_D_dump_prep new_binds
96 return (mod_details { md_binds = new_binds })
98 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
99 corePrepExpr dflags expr
100 = do showPass dflags "CorePrep"
101 us <- mkSplitUniqSupply 's'
102 let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
103 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
107 -- ---------------------------------------------------------------------------
108 -- Dealing with bindings
109 -- ---------------------------------------------------------------------------
111 data FloatingBind = FloatLet CoreBind
112 | FloatCase Id CoreExpr Bool
113 -- The bool indicates "ok-for-speculation"
115 instance Outputable FloatingBind where
116 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
117 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
119 type CloneEnv = IdEnv Id -- Clone local Ids
121 allLazy :: OrdList FloatingBind -> Bool
123 = foldrOL check True floats
125 check (FloatLet _) y = y
126 check (FloatCase _ _ ok_for_spec) y = ok_for_spec && y
127 -- The ok-for-speculation flag says that it's safe to
128 -- float this Case out of a let, and thereby do it more eagerly
129 -- We need the top-level flag because it's never ok to float
130 -- an unboxed binding to the top level
132 -- ---------------------------------------------------------------------------
134 -- ---------------------------------------------------------------------------
136 corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind)
137 corePrepTopBinds env [] = returnUs nilOL
139 corePrepTopBinds env (bind : binds)
140 = corePrepTopBind env bind `thenUs` \ (env', bind') ->
141 corePrepTopBinds env' binds `thenUs` \ binds' ->
142 returnUs (bind' `appOL` binds')
144 -- NB: we do need to float out of top-level bindings
145 -- Consider x = length [True,False]
151 -- We return a *list* of bindings, because we may start with
153 -- where x is demanded, in which case we want to finish with
156 -- And then x will actually end up case-bound
158 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
159 corePrepTopBind env (NonRec bndr rhs)
160 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
161 corePrepRhs TopLevel env (bndr, rhs) `thenUs` \ (floats, rhs') ->
162 returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
164 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
166 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
167 -- This one is used for *local* bindings
168 corePrepBind env (NonRec bndr rhs)
169 = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
170 cloneBndr env bndr `thenUs` \ (env', bndr') ->
171 mkLocalNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
172 returnUs (env', floats')
174 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
176 --------------------------------
177 corePrepRecPairs :: TopLevelFlag -> CloneEnv
178 -> [(Id,CoreExpr)] -- Recursive bindings
179 -> UniqSM (CloneEnv, OrdList FloatingBind)
180 -- Used for all recursive bindings, top level and otherwise
181 corePrepRecPairs lvl env pairs
182 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
183 mapAndUnzipUs (corePrepRhs lvl env') pairs `thenUs` \ (floats_s, rhss') ->
184 returnUs (env', concatOL floats_s `snocOL` FloatLet (Rec (bndrs' `zip` rhss')))
186 --------------------------------
187 corePrepRhs :: TopLevelFlag -> CloneEnv -> (Id, CoreExpr)
188 -> UniqSM (OrdList FloatingBind, CoreExpr)
189 -- Used for top-level bindings, and local recursive bindings
190 corePrepRhs top_lvl env (bndr, rhs)
191 = corePrepExprFloat env rhs `thenUs` \ floats_w_rhs ->
192 floatRhs top_lvl bndr floats_w_rhs
195 -- ---------------------------------------------------------------------------
196 -- Making arguments atomic (function args & constructor args)
197 -- ---------------------------------------------------------------------------
199 -- This is where we arrange that a non-trivial argument is let-bound
200 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
201 -> UniqSM (OrdList FloatingBind, CoreArg)
202 corePrepArg env arg dem
203 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
204 if no_binding_needed arg'
205 then returnUs (floats, arg')
206 else newVar (exprType arg') (exprArity arg') `thenUs` \ v ->
207 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
208 returnUs (floats', Var v)
210 no_binding_needed | opt_RuntimeTypes = exprIsAtom
211 | otherwise = exprIsTrivial
213 -- version that doesn't consider an scc annotation to be trivial.
214 exprIsTrivial (Var v)
215 | hasNoBinding v = idArity v == 0
217 exprIsTrivial (Type _) = True
218 exprIsTrivial (Lit lit) = True
219 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
220 exprIsTrivial (Note (SCC _) e) = False
221 exprIsTrivial (Note _ e) = exprIsTrivial e
222 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
223 exprIsTrivial other = False
225 -- ---------------------------------------------------------------------------
226 -- Dealing with expressions
227 -- ---------------------------------------------------------------------------
229 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
230 corePrepAnExpr env expr
231 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
235 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
239 -- e = let bs in e' (semantically, that is!)
242 -- f (g x) ===> ([v = g x], f v)
244 corePrepExprFloat env (Var v)
245 = fiddleCCall v `thenUs` \ v1 ->
246 let v2 = lookupVarEnv env v1 `orElse` v1 in
247 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
248 returnUs (nilOL, app)
250 corePrepExprFloat env expr@(Type _)
251 = returnUs (nilOL, expr)
253 corePrepExprFloat env expr@(Lit lit)
254 = returnUs (nilOL, expr)
256 corePrepExprFloat env (Let bind body)
257 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
258 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
259 returnUs (new_binds `appOL` floats, new_body)
261 corePrepExprFloat env (Note n@(SCC _) expr)
262 = corePrepAnExpr env expr `thenUs` \ expr1 ->
263 deLam expr1 `thenUs` \ expr2 ->
264 returnUs (nilOL, Note n expr2)
266 corePrepExprFloat env (Note other_note expr)
267 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
268 returnUs (floats, Note other_note expr')
270 corePrepExprFloat env expr@(Lam _ _)
271 = corePrepAnExpr env body `thenUs` \ body' ->
272 returnUs (nilOL, mkLams bndrs body')
274 (bndrs,body) = collectBinders expr
276 corePrepExprFloat env (Case scrut bndr alts)
277 = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
278 cloneBndr env bndr `thenUs` \ (env', bndr') ->
279 mapUs (sat_alt env') alts `thenUs` \ alts' ->
280 returnUs (floats, mkCase scrut' bndr' alts')
282 sat_alt env (con, bs, rhs)
283 = cloneBndrs env bs `thenUs` \ (env', bs') ->
284 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
285 deLam rhs1 `thenUs` \ rhs2 ->
286 returnUs (con, bs', rhs2)
288 corePrepExprFloat env expr@(App _ _)
289 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
290 ASSERT(null ss) -- make sure we used all the strictness info
292 -- Now deal with the function
294 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
295 returnUs (floats, app')
297 _other -> returnUs (floats, app)
301 -- Deconstruct and rebuild the application, floating any non-atomic
302 -- arguments to the outside. We collect the type of the expression,
303 -- the head of the application, and the number of actual value arguments,
304 -- all of which are used to possibly saturate this application if it
305 -- has a constructor or primop at the head.
309 -> Int -- current app depth
310 -> UniqSM (CoreExpr, -- the rebuilt expression
311 (CoreExpr,Int), -- the head of the application,
312 -- and no. of args it was applied to
313 Type, -- type of the whole expr
314 OrdList FloatingBind, -- any floats we pulled out
315 [Demand]) -- remaining argument demands
317 collect_args (App fun arg@(Type arg_ty)) depth
318 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
319 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
321 collect_args (App fun arg) depth
322 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
324 (ss1, ss_rest) = case ss of
325 (ss1:ss_rest) -> (ss1, ss_rest)
327 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
328 splitFunTy_maybe fun_ty
330 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
331 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
333 collect_args (Var v) depth
334 = fiddleCCall v `thenUs` \ v1 ->
335 let v2 = lookupVarEnv env v1 `orElse` v1 in
336 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
338 stricts = case idNewStrictness v of
339 StrictSig (DmdType _ demands _)
340 | depth >= length demands -> demands
342 -- If depth < length demands, then we have too few args to
343 -- satisfy strictness info so we have to ignore all the
344 -- strictness info, e.g. + (error "urk")
345 -- Here, we can't evaluate the arg strictly, because this
346 -- partial application might be seq'd
349 collect_args (Note (Coerce ty1 ty2) fun) depth
350 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
351 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
353 collect_args (Note note fun) depth
355 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
356 returnUs (Note note fun', hd, fun_ty, floats, ss)
358 -- non-variable fun, better let-bind it
359 collect_args fun depth
360 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
361 newVar ty (exprArity fun') `thenUs` \ fn_id ->
362 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
363 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
367 ignore_note InlineCall = True
368 ignore_note InlineMe = True
369 ignore_note _other = False
370 -- we don't ignore SCCs, since they require some code generation
372 ------------------------------------------------------------------------------
373 -- Building the saturated syntax
374 -- ---------------------------------------------------------------------------
376 -- maybeSaturate deals with saturating primops and constructors
377 -- The type is the type of the entire application
378 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
379 maybeSaturate fn expr n_args ty
380 | hasNoBinding fn = saturate_it
381 | otherwise = returnUs expr
383 fn_arity = idArity fn
384 excess_arity = fn_arity - n_args
385 saturate_it = getUniquesUs `thenUs` \ us ->
386 returnUs (etaExpand excess_arity us expr ty)
388 -- ---------------------------------------------------------------------------
389 -- Precipitating the floating bindings
390 -- ---------------------------------------------------------------------------
392 floatRhs :: TopLevelFlag -> Id
393 -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
394 -> UniqSM (OrdList FloatingBind, -- Floats out of this bind
395 CoreExpr) -- Final Rhs
397 floatRhs top_lvl bndr (floats, rhs)
398 | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
399 allLazy floats -- at top level
400 = -- Why the test for allLazy?
401 -- v = f (x `divInt#` y)
402 -- we don't want to float the case, even if f has arity 2,
403 -- because floating the case would make it evaluated too early
405 -- Finally, eta-expand the RHS, for the benefit of the code gen
406 etaExpandRhs bndr rhs `thenUs` \ rhs' ->
407 returnUs (floats, rhs')
410 -- Don't float; the RHS isn't a value
411 = mkBinds floats rhs `thenUs` \ rhs' ->
412 etaExpandRhs bndr rhs' `thenUs` \ rhs'' ->
413 returnUs (nilOL, rhs'')
415 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
416 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
417 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
418 -> UniqSM (OrdList FloatingBind)
420 mkLocalNonRec bndr dem floats rhs
421 | isUnLiftedType (idType bndr) || isStrict dem
422 -- It's a strict let, or the binder is unlifted,
423 -- so we definitely float all the bindings
424 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
425 let -- Don't make a case for a value binding,
426 -- even if it's strict. Otherwise we get
427 -- case (\x -> e) of ...!
428 float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
429 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
431 returnUs (floats `snocOL` float)
434 = floatRhs NotTopLevel bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
435 returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
437 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
439 | isNilOL binds = returnUs body
440 | otherwise = deLam body `thenUs` \ body' ->
441 returnUs (foldrOL mk_bind body' binds)
443 mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
444 mk_bind (FloatLet bind) body = Let bind body
446 etaExpandRhs bndr rhs
447 = -- Eta expand to match the arity claimed by the binder
448 -- Remember, after CorePrep we must not change arity
450 -- Eta expansion might not have happened already,
451 -- because it is done by the simplifier only when
452 -- there at least one lambda already.
454 -- NB1:we could refrain when the RHS is trivial (which can happen
455 -- for exported things). This would reduce the amount of code
456 -- generated (a little) and make things a little words for
457 -- code compiled without -O. The case in point is data constructor
460 -- NB2: we have to be careful that the result of etaExpand doesn't
461 -- invalidate any of the assumptions that CorePrep is attempting
462 -- to establish. One possible cause is eta expanding inside of
463 -- an SCC note - we're now careful in etaExpand to make sure the
464 -- SCC is pushed inside any new lambdas that are generated.
466 getUniquesUs `thenUs` \ us ->
467 returnUs (etaExpand (idArity bndr) us rhs (idType bndr))
469 -- ---------------------------------------------------------------------------
470 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
471 -- We arrange that they only show up as the RHS of a let(rec)
472 -- ---------------------------------------------------------------------------
474 deLam :: CoreExpr -> UniqSM CoreExpr
475 -- Remove top level lambdas by let-bindinig
478 = -- You can get things like
479 -- case e of { p -> coerce t (\s -> ...) }
480 deLam expr `thenUs` \ expr' ->
481 returnUs (Note n expr')
484 | null bndrs = returnUs expr
486 = case tryEta bndrs body of
487 Just no_lam_result -> returnUs no_lam_result
488 Nothing -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn ->
489 returnUs (Let (NonRec fn expr) (Var fn))
491 (bndrs,body) = collectBinders expr
493 -- Why try eta reduction? Hasn't the simplifier already done eta?
494 -- But the simplifier only eta reduces if that leaves something
495 -- trivial (like f, or f Int). But for deLam it would be enough to
496 -- get to a partial application, like (map f).
498 tryEta bndrs expr@(App _ _)
499 | ok_to_eta_reduce f &&
501 and (zipWith ok bndrs last_args) &&
502 not (any (`elemVarSet` fvs_remaining) bndrs)
503 = Just remaining_expr
505 (f, args) = collectArgs expr
506 remaining_expr = mkApps f remaining_args
507 fvs_remaining = exprFreeVars remaining_expr
508 (remaining_args, last_args) = splitAt n_remaining args
509 n_remaining = length args - length bndrs
511 ok bndr (Var arg) = bndr == arg
512 ok bndr other = False
514 -- we can't eta reduce something which must be saturated.
515 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
516 ok_to_eta_reduce _ = False --safe. ToDo: generalise
518 tryEta bndrs (Let bind@(NonRec b r) body)
519 | not (any (`elemVarSet` fvs) bndrs)
520 = case tryEta bndrs body of
521 Just e -> Just (Let bind e)
526 tryEta bndrs _ = Nothing
530 -- -----------------------------------------------------------------------------
531 -- Do the seq and par transformation
532 -- -----------------------------------------------------------------------------
534 Here we do two pre-codegen transformations:
540 case a of { DEFAULT -> rhs }
550 NB: seq# :: a -> Int# -- Evaluate value and return anything
551 par# :: a -> Int# -- Spark value and return anything
553 These transformations can't be done earlier, or else we might
554 think that the expression was strict in the variables in which
555 rhs is strict --- but that would defeat the purpose of seq and par.
559 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
560 -- DEFAULT alt is always first
561 = case isPrimOpId_maybe fn of
562 Just ParOp -> Case scrut bndr [deflt_alt]
563 Just SeqOp -> Case arg new_bndr [deflt_alt]
564 other -> Case scrut bndr alts
566 -- The binder shouldn't be used in the expression!
567 new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
568 setIdType bndr (exprType arg)
569 -- NB: SeqOp :: forall a. a -> Int#
570 -- So bndr has type Int#
571 -- But now we are going to scrutinise the SeqOp's argument directly,
572 -- so we must change the type of the case binder to match that
573 -- of the argument expression e.
575 mkCase scrut bndr alts = Case scrut bndr alts
579 -- -----------------------------------------------------------------------------
581 -- -----------------------------------------------------------------------------
585 = RhsDemand { isStrict :: Bool, -- True => used at least once
586 isOnceDem :: Bool -- True => used at most once
589 mkDem :: Demand -> Bool -> RhsDemand
590 mkDem strict once = RhsDemand (isStrictDmd strict) once
592 mkDemTy :: Demand -> Type -> RhsDemand
593 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
595 isOnceTy :: Type -> Bool
599 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
604 once | u `eqUsage` usOnce = True
605 | u `eqUsage` usMany = False
606 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
608 bdrDem :: Id -> RhsDemand
609 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
611 safeDem, onceDem :: RhsDemand
612 safeDem = RhsDemand False False -- always safe to use this
613 onceDem = RhsDemand False True -- used at most once
619 %************************************************************************
623 %************************************************************************
626 ------------------------------------------------------------------------------
628 -- ---------------------------------------------------------------------------
630 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
631 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
633 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
635 | isGlobalId bndr -- Top level things, which we don't want
636 = returnUs (env, bndr) -- to clone, have become GlobalIds by now
639 = getUniqueUs `thenUs` \ uniq ->
641 bndr' = setVarUnique bndr uniq
643 returnUs (extendVarEnv env bndr bndr', bndr')
645 ------------------------------------------------------------------------------
646 -- Cloning ccall Ids; each must have a unique name,
647 -- to give the code generator a handle to hang it on
648 -- ---------------------------------------------------------------------------
650 fiddleCCall :: Id -> UniqSM Id
652 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
653 returnUs (id `setVarUnique` uniq)
654 | otherwise = returnUs id
656 ------------------------------------------------------------------------------
657 -- Generating new binders
658 -- ---------------------------------------------------------------------------
660 newVar :: Type -> Arity -> UniqSM Id
661 -- We're creating a new let binder, and we must give
662 -- it the right arity for the benefit of the code generator.
665 getUniqueUs `thenUs` \ uniq ->
666 returnUs (mkSysLocal SLIT("sat") uniq ty