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( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
14 import CoreFVs ( exprFreeVars )
15 import CoreLint ( endPass )
17 import Type ( Type, applyTy, splitFunTy_maybe,
18 isUnLiftedType, isUnboxedTupleType, seqType )
19 import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
20 import Var ( Var, Id, setVarUnique )
23 import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
24 isFCallId, isGlobalId,
25 isLocalId, hasNoBinding, idNewStrictness,
26 isDataConId_maybe, idUnfolding
28 import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
29 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
37 import Util ( listLengthCmp )
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. [Not any more; nuked Jun 2002] Do the seq/par munging.
68 6. Clone all local Ids.
69 This means that all such Ids are unique, rather than the
70 weaker guarantee of no clashes which the simplifier provides.
71 And that is what the code generator needs.
73 We don't clone TyVars. The code gen doesn't need that,
74 and doing so would be tiresome because then we'd need
75 to substitute in types.
78 7. Give each dynamic CCall occurrence a fresh unique; this is
79 rather like the cloning step above.
81 8. Inject bindings for the "implicit" Ids:
82 * Constructor wrappers
85 We want curried definitions for all of these in case they
86 aren't inlined by some caller.
88 This is all done modulo type applications and abstractions, so that
89 when type erasure is done for conversion to STG, we don't end up with
90 any trivial or useless bindings.
94 -- -----------------------------------------------------------------------------
96 -- -----------------------------------------------------------------------------
99 corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
100 corePrepPgm dflags mod_details
101 = do showPass dflags "CorePrep"
102 us <- mkSplitUniqSupply 's'
104 let implicit_binds = mkImplicitBinds (md_types mod_details)
105 -- NB: we must feed mkImplicitBinds through corePrep too
106 -- so that they are suitably cloned and eta-expanded
108 binds_out = initUs_ us (
109 corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 ->
110 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
111 returnUs (deFloatTop (floats1 `appOL` floats2))
114 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
115 return (mod_details { md_binds = binds_out })
117 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
118 corePrepExpr dflags expr
119 = do showPass dflags "CorePrep"
120 us <- mkSplitUniqSupply 's'
121 let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
122 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
127 -- -----------------------------------------------------------------------------
129 -- -----------------------------------------------------------------------------
131 Create any necessary "implicit" bindings (data constructors etc).
133 * Constructor workers
134 * Constructor wrappers
135 * Data type record selectors
138 In the latter three cases, the Id contains the unfolding to use for
139 the binding. In the case of data con workers we create the rather
140 strange (non-recursive!) binding
142 $wC = \x y -> $wC x y
144 i.e. a curried constructor that allocates. This means that we can
145 treat the worker for a constructor like any other function in the rest
146 of the compiler. The point here is that CoreToStg will generate a
147 StgConApp for the RHS, rather than a call to the worker (which would
148 give a loop). As Lennart says: the ice is thin here, but it works.
150 Hmm. Should we create bindings for dictionary constructors? They are
151 always fully applied, and the bindings are just there to support
152 partial applications. But it's easier to let them through.
155 mkImplicitBinds type_env
156 = [ NonRec id (get_unfolding id)
157 | id <- implicitTyThingIds (typeEnvElts type_env) ]
158 -- The etaExpand is so that the manifest arity of the
159 -- binding matches its claimed arity, which is an
160 -- invariant of top level bindings going into the code gen
162 get_unfolding id -- See notes above
163 | Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works
164 | otherwise = unfoldingTemplate (idUnfolding id)
169 -- ---------------------------------------------------------------------------
170 -- Dealing with bindings
171 -- ---------------------------------------------------------------------------
173 data FloatingBind = FloatLet CoreBind
174 | FloatCase Id CoreExpr Bool
175 -- The bool indicates "ok-for-speculation"
177 instance Outputable FloatingBind where
178 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
179 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
181 type CloneEnv = IdEnv Id -- Clone local Ids
183 deFloatTop :: OrdList FloatingBind -> [CoreBind]
184 -- For top level only; we don't expect any FloatCases
186 = foldrOL get [] floats
188 get (FloatLet b) bs = b:bs
189 get b bs = pprPanic "corePrepPgm" (ppr b)
191 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
192 allLazy top_lvl is_rec floats
193 = foldrOL check True floats
195 unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
197 check (FloatLet _) y = y
198 check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
199 -- The ok-for-speculation flag says that it's safe to
200 -- float this Case out of a let, and thereby do it more eagerly
201 -- We need the top-level flag because it's never ok to float
202 -- an unboxed binding to the top level
204 -- ---------------------------------------------------------------------------
206 -- ---------------------------------------------------------------------------
208 corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
209 corePrepTopBinds binds
210 = go emptyVarEnv binds
212 go env [] = returnUs nilOL
213 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
214 go env' binds `thenUs` \ binds' ->
215 returnUs (bind' `appOL` binds')
217 -- NB: we do need to float out of top-level bindings
218 -- Consider x = length [True,False]
224 -- We return a *list* of bindings, because we may start with
226 -- where x is demanded, in which case we want to finish with
229 -- And then x will actually end up case-bound
231 --------------------------------
232 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
233 corePrepTopBind env (NonRec bndr rhs)
234 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
235 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
236 returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
238 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
240 --------------------------------
241 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
242 -- This one is used for *local* bindings
243 corePrepBind env (NonRec bndr rhs)
244 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
245 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
246 cloneBndr env bndr `thenUs` \ (env', bndr') ->
247 mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
248 returnUs (env', floats')
250 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
252 --------------------------------
253 corePrepRecPairs :: TopLevelFlag -> CloneEnv
254 -> [(Id,CoreExpr)] -- Recursive bindings
255 -> UniqSM (CloneEnv, OrdList FloatingBind)
256 -- Used for all recursive bindings, top level and otherwise
257 corePrepRecPairs lvl env pairs
258 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
259 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
260 returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
262 -- Flatten all the floats, and the currrent
263 -- group into a single giant Rec
264 flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
266 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
267 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
269 --------------------------------
270 corePrepRhs :: TopLevelFlag -> RecFlag
271 -> CloneEnv -> (Id, CoreExpr)
272 -> UniqSM (OrdList FloatingBind, CoreExpr)
273 -- Used for top-level bindings, and local recursive bindings
274 corePrepRhs top_lvl is_rec env (bndr, rhs)
275 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
276 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
277 floatRhs top_lvl is_rec bndr floats_w_rhs
280 -- ---------------------------------------------------------------------------
281 -- Making arguments atomic (function args & constructor args)
282 -- ---------------------------------------------------------------------------
284 -- This is where we arrange that a non-trivial argument is let-bound
285 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
286 -> UniqSM (OrdList FloatingBind, CoreArg)
287 corePrepArg env arg dem
288 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
289 if exprIsTrivial arg'
290 then returnUs (floats, arg')
291 else newVar (exprType arg') `thenUs` \ v ->
292 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
293 returnUs (floats', Var v)
295 -- version that doesn't consider an scc annotation to be trivial.
296 exprIsTrivial (Var v) = True
297 exprIsTrivial (Type _) = True
298 exprIsTrivial (Lit lit) = True
299 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
300 exprIsTrivial (Note (SCC _) e) = False
301 exprIsTrivial (Note _ e) = exprIsTrivial e
302 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
303 exprIsTrivial other = False
305 -- ---------------------------------------------------------------------------
306 -- Dealing with expressions
307 -- ---------------------------------------------------------------------------
309 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
310 corePrepAnExpr env expr
311 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
315 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
319 -- e = let bs in e' (semantically, that is!)
322 -- f (g x) ===> ([v = g x], f v)
324 corePrepExprFloat env (Var v)
325 = fiddleCCall v `thenUs` \ v1 ->
326 let v2 = lookupVarEnv env v1 `orElse` v1 in
327 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
328 returnUs (nilOL, app)
330 corePrepExprFloat env expr@(Type _)
331 = returnUs (nilOL, expr)
333 corePrepExprFloat env expr@(Lit lit)
334 = returnUs (nilOL, expr)
336 corePrepExprFloat env (Let bind body)
337 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
338 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
339 returnUs (new_binds `appOL` floats, new_body)
341 corePrepExprFloat env (Note n@(SCC _) expr)
342 = corePrepAnExpr env expr `thenUs` \ expr1 ->
343 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
344 returnUs (floats, Note n expr2)
346 corePrepExprFloat env (Note other_note expr)
347 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
348 returnUs (floats, Note other_note expr')
350 corePrepExprFloat env expr@(Lam _ _)
351 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
352 corePrepAnExpr env' body `thenUs` \ body' ->
353 returnUs (nilOL, mkLams bndrs' body')
355 (bndrs,body) = collectBinders expr
357 corePrepExprFloat env (Case scrut bndr alts)
358 = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
359 deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
360 cloneBndr env bndr `thenUs` \ (env', bndr') ->
361 mapUs (sat_alt env') alts `thenUs` \ alts' ->
362 returnUs (floats1 `appOL` floats2 , Case scrut2 bndr' alts')
364 sat_alt env (con, bs, rhs)
365 = cloneBndrs env bs `thenUs` \ (env', bs') ->
366 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
367 deLam rhs1 `thenUs` \ rhs2 ->
368 returnUs (con, bs', rhs2)
370 corePrepExprFloat env expr@(App _ _)
371 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
372 ASSERT(null ss) -- make sure we used all the strictness info
374 -- Now deal with the function
376 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
377 returnUs (floats, app')
379 _other -> returnUs (floats, app)
383 -- Deconstruct and rebuild the application, floating any non-atomic
384 -- arguments to the outside. We collect the type of the expression,
385 -- the head of the application, and the number of actual value arguments,
386 -- all of which are used to possibly saturate this application if it
387 -- has a constructor or primop at the head.
391 -> Int -- current app depth
392 -> UniqSM (CoreExpr, -- the rebuilt expression
393 (CoreExpr,Int), -- the head of the application,
394 -- and no. of args it was applied to
395 Type, -- type of the whole expr
396 OrdList FloatingBind, -- any floats we pulled out
397 [Demand]) -- remaining argument demands
399 collect_args (App fun arg@(Type arg_ty)) depth
400 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
401 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
403 collect_args (App fun arg) depth
404 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
406 (ss1, ss_rest) = case ss of
407 (ss1:ss_rest) -> (ss1, ss_rest)
409 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
410 splitFunTy_maybe fun_ty
412 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
413 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
415 collect_args (Var v) depth
416 = fiddleCCall v `thenUs` \ v1 ->
417 let v2 = lookupVarEnv env v1 `orElse` v1 in
418 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
420 stricts = case idNewStrictness v of
421 StrictSig (DmdType _ demands _)
422 | listLengthCmp demands depth /= GT -> demands
423 -- length demands <= depth
425 -- If depth < length demands, then we have too few args to
426 -- satisfy strictness info so we have to ignore all the
427 -- strictness info, e.g. + (error "urk")
428 -- Here, we can't evaluate the arg strictly, because this
429 -- partial application might be seq'd
432 collect_args (Note (Coerce ty1 ty2) fun) depth
433 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
434 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
436 collect_args (Note note fun) depth
438 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
439 returnUs (Note note fun', hd, fun_ty, floats, ss)
441 -- non-variable fun, better let-bind it
442 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
443 -- since it is sure to be evaluated.
444 collect_args fun depth
445 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
446 newVar ty `thenUs` \ fn_id ->
447 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
448 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
452 ignore_note InlineCall = True
453 ignore_note InlineMe = True
454 ignore_note _other = False
455 -- we don't ignore SCCs, since they require some code generation
457 ------------------------------------------------------------------------------
458 -- Building the saturated syntax
459 -- ---------------------------------------------------------------------------
461 -- maybeSaturate deals with saturating primops and constructors
462 -- The type is the type of the entire application
463 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
464 maybeSaturate fn expr n_args ty
465 | hasNoBinding fn = saturate_it
466 | otherwise = returnUs expr
468 fn_arity = idArity fn
469 excess_arity = fn_arity - n_args
470 saturate_it = getUniquesUs `thenUs` \ us ->
471 returnUs (etaExpand excess_arity us expr ty)
473 -- ---------------------------------------------------------------------------
474 -- Precipitating the floating bindings
475 -- ---------------------------------------------------------------------------
477 floatRhs :: TopLevelFlag -> RecFlag
479 -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
480 -> UniqSM (OrdList FloatingBind, -- Floats out of this bind
481 CoreExpr) -- Final Rhs
483 floatRhs top_lvl is_rec bndr (floats, rhs)
484 | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
485 allLazy top_lvl is_rec floats -- at top level
486 = -- Why the test for allLazy?
487 -- v = f (x `divInt#` y)
488 -- we don't want to float the case, even if f has arity 2,
489 -- because floating the case would make it evaluated too early
491 -- Finally, eta-expand the RHS, for the benefit of the code gen
492 returnUs (floats, rhs)
495 -- Don't float; the RHS isn't a value
496 = mkBinds floats rhs `thenUs` \ rhs' ->
497 returnUs (nilOL, rhs')
499 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
500 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
501 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
502 -> UniqSM (OrdList FloatingBind)
504 mkLocalNonRec bndr dem floats rhs
505 | isUnLiftedType (idType bndr)
506 -- If this is an unlifted binding, we always make a case for it.
507 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
509 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
511 returnUs (floats `snocOL` float)
514 -- It's a strict let so we definitely float all the bindings
515 = let -- Don't make a case for a value binding,
516 -- even if it's strict. Otherwise we get
517 -- case (\x -> e) of ...!
518 float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
519 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
521 returnUs (floats `snocOL` float)
524 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
525 returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
528 bndr_ty = idType bndr
531 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
533 | isNilOL binds = returnUs body
534 | otherwise = deLam body `thenUs` \ body' ->
535 returnUs (foldrOL mk_bind body' binds)
537 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
538 mk_bind (FloatLet bind) body = Let bind body
540 etaExpandRhs bndr rhs
541 = -- Eta expand to match the arity claimed by the binder
542 -- Remember, after CorePrep we must not change arity
544 -- Eta expansion might not have happened already,
545 -- because it is done by the simplifier only when
546 -- there at least one lambda already.
548 -- NB1:we could refrain when the RHS is trivial (which can happen
549 -- for exported things). This would reduce the amount of code
550 -- generated (a little) and make things a little words for
551 -- code compiled without -O. The case in point is data constructor
554 -- NB2: we have to be careful that the result of etaExpand doesn't
555 -- invalidate any of the assumptions that CorePrep is attempting
556 -- to establish. One possible cause is eta expanding inside of
557 -- an SCC note - we're now careful in etaExpand to make sure the
558 -- SCC is pushed inside any new lambdas that are generated.
560 -- NB3: It's important to do eta expansion, and *then* ANF-ising
561 -- f = /\a -> g (h 3) -- h has arity 2
562 -- If we ANF first we get
563 -- f = /\a -> let s = h 3 in g s
564 -- and now eta expansion gives
565 -- f = /\a -> \ y -> (let s = h 3 in g s) y
566 -- which is horrible.
567 -- Eta expanding first gives
568 -- f = /\a -> \y -> let s = h 3 in g s y
570 getUniquesUs `thenUs` \ us ->
571 returnUs (etaExpand arity us rhs (idType bndr))
573 -- For a GlobalId, take the Arity from the Id.
574 -- It was set in CoreTidy and must not change
575 -- For all others, just expand at will
576 arity | isGlobalId bndr = idArity bndr
577 | otherwise = exprArity rhs
579 -- ---------------------------------------------------------------------------
580 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
581 -- We arrange that they only show up as the RHS of a let(rec)
582 -- ---------------------------------------------------------------------------
584 deLam :: CoreExpr -> UniqSM CoreExpr
586 deLamFloat expr `thenUs` \ (floats, expr) ->
590 deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
591 -- Remove top level lambdas by let-bindinig
593 deLamFloat (Note n expr)
594 = -- You can get things like
595 -- case e of { p -> coerce t (\s -> ...) }
596 deLamFloat expr `thenUs` \ (floats, expr') ->
597 returnUs (floats, Note n expr')
600 | null bndrs = returnUs (nilOL, expr)
602 = case tryEta bndrs body of
603 Just no_lam_result -> returnUs (nilOL, no_lam_result)
604 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
605 returnUs (unitOL (FloatLet (NonRec fn expr)),
608 (bndrs,body) = collectBinders expr
610 -- Why try eta reduction? Hasn't the simplifier already done eta?
611 -- But the simplifier only eta reduces if that leaves something
612 -- trivial (like f, or f Int). But for deLam it would be enough to
613 -- get to a partial application, like (map f).
615 tryEta bndrs expr@(App _ _)
616 | ok_to_eta_reduce f &&
618 and (zipWith ok bndrs last_args) &&
619 not (any (`elemVarSet` fvs_remaining) bndrs)
620 = Just remaining_expr
622 (f, args) = collectArgs expr
623 remaining_expr = mkApps f remaining_args
624 fvs_remaining = exprFreeVars remaining_expr
625 (remaining_args, last_args) = splitAt n_remaining args
626 n_remaining = length args - length bndrs
628 ok bndr (Var arg) = bndr == arg
629 ok bndr other = False
631 -- we can't eta reduce something which must be saturated.
632 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
633 ok_to_eta_reduce _ = False --safe. ToDo: generalise
635 tryEta bndrs (Let bind@(NonRec b r) body)
636 | not (any (`elemVarSet` fvs) bndrs)
637 = case tryEta bndrs body of
638 Just e -> Just (Let bind e)
643 tryEta bndrs _ = Nothing
647 -- -----------------------------------------------------------------------------
649 -- -----------------------------------------------------------------------------
653 = RhsDemand { isStrict :: Bool, -- True => used at least once
654 isOnceDem :: Bool -- True => used at most once
657 mkDem :: Demand -> Bool -> RhsDemand
658 mkDem strict once = RhsDemand (isStrictDmd strict) once
660 mkDemTy :: Demand -> Type -> RhsDemand
661 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
664 bdrDem :: Id -> RhsDemand
665 bdrDem id = mkDem (idNewDemandInfo id)
668 -- safeDem :: RhsDemand
669 -- safeDem = RhsDemand False False -- always safe to use this
672 onceDem = RhsDemand False True -- used at most once
678 %************************************************************************
682 %************************************************************************
685 ------------------------------------------------------------------------------
687 -- ---------------------------------------------------------------------------
689 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
690 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
692 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
695 = getUniqueUs `thenUs` \ uniq ->
697 bndr' = setVarUnique bndr uniq
699 returnUs (extendVarEnv env bndr bndr', bndr')
701 | otherwise -- Top level things, which we don't want
702 -- to clone, have become GlobalIds by now
703 -- And we don't clone tyvars
704 = returnUs (env, bndr)
707 ------------------------------------------------------------------------------
708 -- Cloning ccall Ids; each must have a unique name,
709 -- to give the code generator a handle to hang it on
710 -- ---------------------------------------------------------------------------
712 fiddleCCall :: Id -> UniqSM Id
714 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
715 returnUs (id `setVarUnique` uniq)
716 | otherwise = returnUs id
718 ------------------------------------------------------------------------------
719 -- Generating new binders
720 -- ---------------------------------------------------------------------------
722 newVar :: Type -> UniqSM Id
725 getUniqueUs `thenUs` \ uniq ->
726 returnUs (mkSysLocal FSLIT("sat") uniq ty)