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 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
174 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
175 cloneBndr env bndr `thenUs` \ (env', bndr') ->
176 mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
177 returnUs (env', floats')
179 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
181 --------------------------------
182 corePrepRecPairs :: TopLevelFlag -> CloneEnv
183 -> [(Id,CoreExpr)] -- Recursive bindings
184 -> UniqSM (CloneEnv, OrdList FloatingBind)
185 -- Used for all recursive bindings, top level and otherwise
186 corePrepRecPairs lvl env pairs
187 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
188 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
189 returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
191 -- Flatten all the floats, and the currrent
192 -- group into a single giant Rec
193 flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
195 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
196 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
198 --------------------------------
199 corePrepRhs :: TopLevelFlag -> RecFlag
200 -> CloneEnv -> (Id, CoreExpr)
201 -> UniqSM (OrdList FloatingBind, CoreExpr)
202 -- Used for top-level bindings, and local recursive bindings
203 corePrepRhs top_lvl is_rec env (bndr, rhs)
204 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
205 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
206 floatRhs top_lvl is_rec bndr floats_w_rhs
209 -- ---------------------------------------------------------------------------
210 -- Making arguments atomic (function args & constructor args)
211 -- ---------------------------------------------------------------------------
213 -- This is where we arrange that a non-trivial argument is let-bound
214 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
215 -> UniqSM (OrdList FloatingBind, CoreArg)
216 corePrepArg env arg dem
217 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
218 if exprIsTrivial arg'
219 then returnUs (floats, arg')
220 else newVar (exprType arg') (exprArity arg') `thenUs` \ v ->
221 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
222 returnUs (floats', Var v)
224 -- version that doesn't consider an scc annotation to be trivial.
225 exprIsTrivial (Var v)
226 | hasNoBinding v = idArity v == 0
228 exprIsTrivial (Type _) = True
229 exprIsTrivial (Lit lit) = True
230 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
231 exprIsTrivial (Note (SCC _) e) = False
232 exprIsTrivial (Note _ e) = exprIsTrivial e
233 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
234 exprIsTrivial other = False
236 -- ---------------------------------------------------------------------------
237 -- Dealing with expressions
238 -- ---------------------------------------------------------------------------
240 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
241 corePrepAnExpr env expr
242 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
246 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
250 -- e = let bs in e' (semantically, that is!)
253 -- f (g x) ===> ([v = g x], f v)
255 corePrepExprFloat env (Var v)
256 = fiddleCCall v `thenUs` \ v1 ->
257 let v2 = lookupVarEnv env v1 `orElse` v1 in
258 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
259 returnUs (nilOL, app)
261 corePrepExprFloat env expr@(Type _)
262 = returnUs (nilOL, expr)
264 corePrepExprFloat env expr@(Lit lit)
265 = returnUs (nilOL, expr)
267 corePrepExprFloat env (Let bind body)
268 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
269 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
270 returnUs (new_binds `appOL` floats, new_body)
272 corePrepExprFloat env (Note n@(SCC _) expr)
273 = corePrepAnExpr env expr `thenUs` \ expr1 ->
274 deLam expr1 `thenUs` \ expr2 ->
275 returnUs (nilOL, Note n expr2)
277 corePrepExprFloat env (Note other_note expr)
278 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
279 returnUs (floats, Note other_note expr')
281 corePrepExprFloat env expr@(Lam _ _)
282 = corePrepAnExpr env body `thenUs` \ body' ->
283 returnUs (nilOL, mkLams bndrs body')
285 (bndrs,body) = collectBinders expr
287 corePrepExprFloat env (Case scrut bndr alts)
288 = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
289 cloneBndr env bndr `thenUs` \ (env', bndr') ->
290 mapUs (sat_alt env') alts `thenUs` \ alts' ->
291 returnUs (floats, mkCase scrut' bndr' alts')
293 sat_alt env (con, bs, rhs)
294 = cloneBndrs env bs `thenUs` \ (env', bs') ->
295 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
296 deLam rhs1 `thenUs` \ rhs2 ->
297 returnUs (con, bs', rhs2)
299 corePrepExprFloat env expr@(App _ _)
300 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
301 ASSERT(null ss) -- make sure we used all the strictness info
303 -- Now deal with the function
305 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
306 returnUs (floats, app')
308 _other -> returnUs (floats, app)
312 -- Deconstruct and rebuild the application, floating any non-atomic
313 -- arguments to the outside. We collect the type of the expression,
314 -- the head of the application, and the number of actual value arguments,
315 -- all of which are used to possibly saturate this application if it
316 -- has a constructor or primop at the head.
320 -> Int -- current app depth
321 -> UniqSM (CoreExpr, -- the rebuilt expression
322 (CoreExpr,Int), -- the head of the application,
323 -- and no. of args it was applied to
324 Type, -- type of the whole expr
325 OrdList FloatingBind, -- any floats we pulled out
326 [Demand]) -- remaining argument demands
328 collect_args (App fun arg@(Type arg_ty)) depth
329 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
330 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
332 collect_args (App fun arg) depth
333 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
335 (ss1, ss_rest) = case ss of
336 (ss1:ss_rest) -> (ss1, ss_rest)
338 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
339 splitFunTy_maybe fun_ty
341 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
342 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
344 collect_args (Var v) depth
345 = fiddleCCall v `thenUs` \ v1 ->
346 let v2 = lookupVarEnv env v1 `orElse` v1 in
347 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
349 stricts = case idNewStrictness v of
350 StrictSig (DmdType _ demands _)
351 | depth >= length demands -> demands
353 -- If depth < length demands, then we have too few args to
354 -- satisfy strictness info so we have to ignore all the
355 -- strictness info, e.g. + (error "urk")
356 -- Here, we can't evaluate the arg strictly, because this
357 -- partial application might be seq'd
360 collect_args (Note (Coerce ty1 ty2) fun) depth
361 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
362 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
364 collect_args (Note note fun) depth
366 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
367 returnUs (Note note fun', hd, fun_ty, floats, ss)
369 -- non-variable fun, better let-bind it
370 collect_args fun depth
371 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
372 newVar ty (exprArity fun') `thenUs` \ fn_id ->
373 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
374 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
378 ignore_note InlineCall = True
379 ignore_note InlineMe = True
380 ignore_note _other = False
381 -- we don't ignore SCCs, since they require some code generation
383 ------------------------------------------------------------------------------
384 -- Building the saturated syntax
385 -- ---------------------------------------------------------------------------
387 -- maybeSaturate deals with saturating primops and constructors
388 -- The type is the type of the entire application
389 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
390 maybeSaturate fn expr n_args ty
391 | hasNoBinding fn = saturate_it
392 | otherwise = returnUs expr
394 fn_arity = idArity fn
395 excess_arity = fn_arity - n_args
396 saturate_it = getUniquesUs `thenUs` \ us ->
397 returnUs (etaExpand excess_arity us expr ty)
399 -- ---------------------------------------------------------------------------
400 -- Precipitating the floating bindings
401 -- ---------------------------------------------------------------------------
403 floatRhs :: TopLevelFlag -> RecFlag
405 -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
406 -> UniqSM (OrdList FloatingBind, -- Floats out of this bind
407 CoreExpr) -- Final Rhs
409 floatRhs top_lvl is_rec bndr (floats, rhs)
410 | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
411 allLazy top_lvl is_rec floats -- at top level
412 = -- Why the test for allLazy?
413 -- v = f (x `divInt#` y)
414 -- we don't want to float the case, even if f has arity 2,
415 -- because floating the case would make it evaluated too early
417 -- Finally, eta-expand the RHS, for the benefit of the code gen
418 returnUs (floats, rhs)
421 -- Don't float; the RHS isn't a value
422 = mkBinds floats rhs `thenUs` \ rhs' ->
423 returnUs (nilOL, rhs')
425 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
426 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
427 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
428 -> UniqSM (OrdList FloatingBind)
430 mkLocalNonRec bndr dem floats rhs
431 | isUnLiftedType (idType bndr) || isStrict dem
432 -- It's a strict let, or the binder is unlifted,
433 -- so we definitely float all the bindings
434 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
435 let -- Don't make a case for a value binding,
436 -- even if it's strict. Otherwise we get
437 -- case (\x -> e) of ...!
438 float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
439 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
441 returnUs (floats `snocOL` float)
444 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
445 returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
447 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
449 | isNilOL binds = returnUs body
450 | otherwise = deLam body `thenUs` \ body' ->
451 returnUs (foldrOL mk_bind body' binds)
453 mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
454 mk_bind (FloatLet bind) body = Let bind body
456 etaExpandRhs bndr rhs
457 = -- Eta expand to match the arity claimed by the binder
458 -- Remember, after CorePrep we must not change arity
460 -- Eta expansion might not have happened already,
461 -- because it is done by the simplifier only when
462 -- there at least one lambda already.
464 -- NB1:we could refrain when the RHS is trivial (which can happen
465 -- for exported things). This would reduce the amount of code
466 -- generated (a little) and make things a little words for
467 -- code compiled without -O. The case in point is data constructor
470 -- NB2: we have to be careful that the result of etaExpand doesn't
471 -- invalidate any of the assumptions that CorePrep is attempting
472 -- to establish. One possible cause is eta expanding inside of
473 -- an SCC note - we're now careful in etaExpand to make sure the
474 -- SCC is pushed inside any new lambdas that are generated.
476 -- NB3: It's important to do eta expansion, and *then* ANF-ising
477 -- f = /\a -> g (h 3) -- h has arity 2
478 -- If we ANF first we get
479 -- f = /\a -> let s = h 3 in g s
480 -- and now eta expansion gives
481 -- f = /\a -> \ y -> (let s = h 3 in g s) y
482 -- which is horrible.
483 -- Eta expanding first gives
484 -- f = /\a -> \y -> let s = h 3 in g s y
486 getUniquesUs `thenUs` \ us ->
487 returnUs (etaExpand (idArity bndr) us rhs (idType bndr))
489 -- ---------------------------------------------------------------------------
490 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
491 -- We arrange that they only show up as the RHS of a let(rec)
492 -- ---------------------------------------------------------------------------
494 deLam :: CoreExpr -> UniqSM CoreExpr
495 -- Remove top level lambdas by let-bindinig
498 = -- You can get things like
499 -- case e of { p -> coerce t (\s -> ...) }
500 deLam expr `thenUs` \ expr' ->
501 returnUs (Note n expr')
504 | null bndrs = returnUs expr
506 = case tryEta bndrs body of
507 Just no_lam_result -> returnUs no_lam_result
508 Nothing -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn ->
509 returnUs (Let (NonRec fn expr) (Var fn))
511 (bndrs,body) = collectBinders expr
513 -- Why try eta reduction? Hasn't the simplifier already done eta?
514 -- But the simplifier only eta reduces if that leaves something
515 -- trivial (like f, or f Int). But for deLam it would be enough to
516 -- get to a partial application, like (map f).
518 tryEta bndrs expr@(App _ _)
519 | ok_to_eta_reduce f &&
521 and (zipWith ok bndrs last_args) &&
522 not (any (`elemVarSet` fvs_remaining) bndrs)
523 = Just remaining_expr
525 (f, args) = collectArgs expr
526 remaining_expr = mkApps f remaining_args
527 fvs_remaining = exprFreeVars remaining_expr
528 (remaining_args, last_args) = splitAt n_remaining args
529 n_remaining = length args - length bndrs
531 ok bndr (Var arg) = bndr == arg
532 ok bndr other = False
534 -- we can't eta reduce something which must be saturated.
535 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
536 ok_to_eta_reduce _ = False --safe. ToDo: generalise
538 tryEta bndrs (Let bind@(NonRec b r) body)
539 | not (any (`elemVarSet` fvs) bndrs)
540 = case tryEta bndrs body of
541 Just e -> Just (Let bind e)
546 tryEta bndrs _ = Nothing
550 -- -----------------------------------------------------------------------------
551 -- Do the seq and par transformation
552 -- -----------------------------------------------------------------------------
554 Here we do two pre-codegen transformations:
560 case a of { DEFAULT -> rhs }
570 NB: seq# :: a -> Int# -- Evaluate value and return anything
571 par# :: a -> Int# -- Spark value and return anything
573 These transformations can't be done earlier, or else we might
574 think that the expression was strict in the variables in which
575 rhs is strict --- but that would defeat the purpose of seq and par.
579 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
580 -- DEFAULT alt is always first
581 = case isPrimOpId_maybe fn of
582 Just ParOp -> Case scrut bndr [deflt_alt]
583 Just SeqOp -> Case arg new_bndr [deflt_alt]
584 other -> Case scrut bndr alts
586 -- The binder shouldn't be used in the expression!
587 new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
588 setIdType bndr (exprType arg)
589 -- NB: SeqOp :: forall a. a -> Int#
590 -- So bndr has type Int#
591 -- But now we are going to scrutinise the SeqOp's argument directly,
592 -- so we must change the type of the case binder to match that
593 -- of the argument expression e.
595 mkCase scrut bndr alts = Case scrut bndr alts
599 -- -----------------------------------------------------------------------------
601 -- -----------------------------------------------------------------------------
605 = RhsDemand { isStrict :: Bool, -- True => used at least once
606 isOnceDem :: Bool -- True => used at most once
609 mkDem :: Demand -> Bool -> RhsDemand
610 mkDem strict once = RhsDemand (isStrictDmd strict) once
612 mkDemTy :: Demand -> Type -> RhsDemand
613 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
615 isOnceTy :: Type -> Bool
619 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
624 once | u `eqUsage` usOnce = True
625 | u `eqUsage` usMany = False
626 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
628 bdrDem :: Id -> RhsDemand
629 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
631 safeDem, onceDem :: RhsDemand
632 safeDem = RhsDemand False False -- always safe to use this
633 onceDem = RhsDemand False True -- used at most once
639 %************************************************************************
643 %************************************************************************
646 ------------------------------------------------------------------------------
648 -- ---------------------------------------------------------------------------
650 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
651 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
653 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
655 | isGlobalId bndr -- Top level things, which we don't want
656 = returnUs (env, bndr) -- to clone, have become GlobalIds by now
659 = getUniqueUs `thenUs` \ uniq ->
661 bndr' = setVarUnique bndr uniq
663 returnUs (extendVarEnv env bndr bndr', bndr')
665 ------------------------------------------------------------------------------
666 -- Cloning ccall Ids; each must have a unique name,
667 -- to give the code generator a handle to hang it on
668 -- ---------------------------------------------------------------------------
670 fiddleCCall :: Id -> UniqSM Id
672 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
673 returnUs (id `setVarUnique` uniq)
674 | otherwise = returnUs id
676 ------------------------------------------------------------------------------
677 -- Generating new binders
678 -- ---------------------------------------------------------------------------
680 newVar :: Type -> Arity -> UniqSM Id
681 -- We're creating a new let binder, and we must give
682 -- it the right arity for the benefit of the code generator.
685 getUniqueUs `thenUs` \ uniq ->
686 returnUs (mkSysLocal SLIT("sat") uniq ty