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 TcType ( TyThing( AnId ) )
20 import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
21 import Var ( Var, Id, setVarUnique )
24 import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
25 isFCallId, isGlobalId, isImplicitId,
26 isLocalId, hasNoBinding, idNewStrictness,
27 idUnfolding, isDataConWorkId_maybe
29 import HscTypes ( TypeEnv, typeEnvElts )
30 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
38 import Util ( listLengthCmp )
42 -- ---------------------------------------------------------------------------
44 -- ---------------------------------------------------------------------------
46 The goal of this pass is to prepare for code generation.
48 1. Saturate constructor and primop applications.
50 2. Convert to A-normal form:
52 * Use case for strict arguments:
53 f E ==> case E of x -> f x
56 * Use let for non-trivial lazy arguments
57 f E ==> let x = E in f x
58 (were f is lazy and x is non-trivial)
60 3. Similarly, convert any unboxed lets into cases.
61 [I'm experimenting with leaving 'ok-for-speculation'
62 rhss in let-form right up to this point.]
64 4. Ensure that lambdas only occur as the RHS of a binding
65 (The code generator can't deal with anything else.)
67 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
69 6. Clone all local Ids.
70 This means that all such Ids are unique, rather than the
71 weaker guarantee of no clashes which the simplifier provides.
72 And that is what the code generator needs.
74 We don't clone TyVars. The code gen doesn't need that,
75 and doing so would be tiresome because then we'd need
76 to substitute in types.
79 7. Give each dynamic CCall occurrence a fresh unique; this is
80 rather like the cloning step above.
82 8. Inject bindings for the "implicit" Ids:
83 * Constructor wrappers
86 We want curried definitions for all of these in case they
87 aren't inlined by some caller.
89 This is all done modulo type applications and abstractions, so that
90 when type erasure is done for conversion to STG, we don't end up with
91 any trivial or useless bindings.
95 -- -----------------------------------------------------------------------------
97 -- -----------------------------------------------------------------------------
100 corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
101 corePrepPgm dflags binds types
102 = do showPass dflags "CorePrep"
103 us <- mkSplitUniqSupply 's'
105 let implicit_binds = mkImplicitBinds types
106 -- NB: we must feed mkImplicitBinds through corePrep too
107 -- so that they are suitably cloned and eta-expanded
109 binds_out = initUs_ us (
110 corePrepTopBinds binds `thenUs` \ floats1 ->
111 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
112 returnUs (deFloatTop (floats1 `appOL` floats2))
115 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
118 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
119 corePrepExpr dflags expr
120 = do showPass dflags "CorePrep"
121 us <- mkSplitUniqSupply 's'
122 let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
123 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
128 -- -----------------------------------------------------------------------------
130 -- -----------------------------------------------------------------------------
132 Create any necessary "implicit" bindings (data constructors etc).
134 * Constructor workers
135 * Constructor wrappers
136 * Data type record selectors
139 In the latter three cases, the Id contains the unfolding to use for
140 the binding. In the case of data con workers we create the rather
141 strange (non-recursive!) binding
143 $wC = \x y -> $wC x y
145 i.e. a curried constructor that allocates. This means that we can
146 treat the worker for a constructor like any other function in the rest
147 of the compiler. The point here is that CoreToStg will generate a
148 StgConApp for the RHS, rather than a call to the worker (which would
149 give a loop). As Lennart says: the ice is thin here, but it works.
151 Hmm. Should we create bindings for dictionary constructors? They are
152 always fully applied, and the bindings are just there to support
153 partial applications. But it's easier to let them through.
156 mkImplicitBinds type_env
157 = [ NonRec id (get_unfolding id)
158 | AnId id <- typeEnvElts type_env, isImplicitId id ]
159 -- The type environment already contains all the implicit Ids,
160 -- so we just filter them out
162 -- The etaExpand is so that the manifest arity of the
163 -- binding matches its claimed arity, which is an
164 -- invariant of top level bindings going into the code gen
166 get_unfolding id -- See notes above
167 | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works
168 -- CorePrep will eta-expand it
169 | otherwise = unfoldingTemplate (idUnfolding id)
174 -- ---------------------------------------------------------------------------
175 -- Dealing with bindings
176 -- ---------------------------------------------------------------------------
178 data FloatingBind = FloatLet CoreBind
179 | FloatCase Id CoreExpr Bool
180 -- The bool indicates "ok-for-speculation"
182 instance Outputable FloatingBind where
183 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
184 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
186 type CloneEnv = IdEnv Id -- Clone local Ids
188 deFloatTop :: OrdList FloatingBind -> [CoreBind]
189 -- For top level only; we don't expect any FloatCases
191 = foldrOL get [] floats
193 get (FloatLet b) bs = b:bs
194 get b bs = pprPanic "corePrepPgm" (ppr b)
196 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
197 allLazy top_lvl is_rec floats
198 = foldrOL check True floats
200 unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
202 check (FloatLet _) y = y
203 check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
204 -- The ok-for-speculation flag says that it's safe to
205 -- float this Case out of a let, and thereby do it more eagerly
206 -- We need the top-level flag because it's never ok to float
207 -- an unboxed binding to the top level
209 -- ---------------------------------------------------------------------------
211 -- ---------------------------------------------------------------------------
213 corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
214 corePrepTopBinds binds
215 = go emptyVarEnv binds
217 go env [] = returnUs nilOL
218 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
219 go env' binds `thenUs` \ binds' ->
220 returnUs (bind' `appOL` binds')
222 -- NB: we do need to float out of top-level bindings
223 -- Consider x = length [True,False]
229 -- We return a *list* of bindings, because we may start with
231 -- where x is demanded, in which case we want to finish with
234 -- And then x will actually end up case-bound
236 -- What happens to the CafInfo on the floated bindings? By
237 -- default, all the CafInfos will be set to MayHaveCafRefs,
240 -- This might be pessimistic, because eg. s1 & s2
241 -- might not refer to any CAFs and the GC will end up doing
242 -- more traversal than is necessary, but it's still better
243 -- than not floating the bindings at all, because then
244 -- the GC would have to traverse the structure in the heap
245 -- instead. Given this, we decided not to try to get
246 -- the CafInfo on the floated bindings correct, because
247 -- it looks difficult.
249 --------------------------------
250 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
251 corePrepTopBind env (NonRec bndr rhs)
252 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
253 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
254 returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
256 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
258 --------------------------------
259 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
260 -- This one is used for *local* bindings
261 corePrepBind env (NonRec bndr rhs)
262 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
263 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
264 cloneBndr env bndr `thenUs` \ (env', bndr') ->
265 mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
266 returnUs (env', floats')
268 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
270 --------------------------------
271 corePrepRecPairs :: TopLevelFlag -> CloneEnv
272 -> [(Id,CoreExpr)] -- Recursive bindings
273 -> UniqSM (CloneEnv, OrdList FloatingBind)
274 -- Used for all recursive bindings, top level and otherwise
275 corePrepRecPairs lvl env pairs
276 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
277 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
278 returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
280 -- Flatten all the floats, and the currrent
281 -- group into a single giant Rec
282 flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
284 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
285 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
287 --------------------------------
288 corePrepRhs :: TopLevelFlag -> RecFlag
289 -> CloneEnv -> (Id, CoreExpr)
290 -> UniqSM (OrdList FloatingBind, CoreExpr)
291 -- Used for top-level bindings, and local recursive bindings
292 corePrepRhs top_lvl is_rec env (bndr, rhs)
293 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
294 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
295 floatRhs top_lvl is_rec bndr floats_w_rhs
298 -- ---------------------------------------------------------------------------
299 -- Making arguments atomic (function args & constructor args)
300 -- ---------------------------------------------------------------------------
302 -- This is where we arrange that a non-trivial argument is let-bound
303 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
304 -> UniqSM (OrdList FloatingBind, CoreArg)
305 corePrepArg env arg dem
306 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
307 if exprIsTrivial arg'
308 then returnUs (floats, arg')
309 else newVar (exprType arg') `thenUs` \ v ->
310 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
311 returnUs (floats', Var v)
313 -- version that doesn't consider an scc annotation to be trivial.
314 exprIsTrivial (Var v) = True
315 exprIsTrivial (Type _) = True
316 exprIsTrivial (Lit lit) = True
317 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
318 exprIsTrivial (Note (SCC _) e) = False
319 exprIsTrivial (Note _ e) = exprIsTrivial e
320 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
321 exprIsTrivial other = False
323 -- ---------------------------------------------------------------------------
324 -- Dealing with expressions
325 -- ---------------------------------------------------------------------------
327 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
328 corePrepAnExpr env expr
329 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
333 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
337 -- e = let bs in e' (semantically, that is!)
340 -- f (g x) ===> ([v = g x], f v)
342 corePrepExprFloat env (Var v)
343 = fiddleCCall v `thenUs` \ v1 ->
344 let v2 = lookupVarEnv env v1 `orElse` v1 in
345 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
346 returnUs (nilOL, app)
348 corePrepExprFloat env expr@(Type _)
349 = returnUs (nilOL, expr)
351 corePrepExprFloat env expr@(Lit lit)
352 = returnUs (nilOL, expr)
354 corePrepExprFloat env (Let bind body)
355 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
356 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
357 returnUs (new_binds `appOL` floats, new_body)
359 corePrepExprFloat env (Note n@(SCC _) expr)
360 = corePrepAnExpr env expr `thenUs` \ expr1 ->
361 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
362 returnUs (floats, Note n expr2)
364 corePrepExprFloat env (Note other_note expr)
365 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
366 returnUs (floats, Note other_note expr')
368 corePrepExprFloat env expr@(Lam _ _)
369 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
370 corePrepAnExpr env' body `thenUs` \ body' ->
371 returnUs (nilOL, mkLams bndrs' body')
373 (bndrs,body) = collectBinders expr
375 corePrepExprFloat env (Case scrut bndr alts)
376 = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
377 deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
378 cloneBndr env bndr `thenUs` \ (env', bndr') ->
379 mapUs (sat_alt env') alts `thenUs` \ alts' ->
380 returnUs (floats1 `appOL` floats2 , Case scrut2 bndr' alts')
382 sat_alt env (con, bs, rhs)
383 = cloneBndrs env bs `thenUs` \ (env', bs') ->
384 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
385 deLam rhs1 `thenUs` \ rhs2 ->
386 returnUs (con, bs', rhs2)
388 corePrepExprFloat env expr@(App _ _)
389 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
390 ASSERT(null ss) -- make sure we used all the strictness info
392 -- Now deal with the function
394 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
395 returnUs (floats, app')
397 _other -> returnUs (floats, app)
401 -- Deconstruct and rebuild the application, floating any non-atomic
402 -- arguments to the outside. We collect the type of the expression,
403 -- the head of the application, and the number of actual value arguments,
404 -- all of which are used to possibly saturate this application if it
405 -- has a constructor or primop at the head.
409 -> Int -- current app depth
410 -> UniqSM (CoreExpr, -- the rebuilt expression
411 (CoreExpr,Int), -- the head of the application,
412 -- and no. of args it was applied to
413 Type, -- type of the whole expr
414 OrdList FloatingBind, -- any floats we pulled out
415 [Demand]) -- remaining argument demands
417 collect_args (App fun arg@(Type arg_ty)) depth
418 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
419 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
421 collect_args (App fun arg) depth
422 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
424 (ss1, ss_rest) = case ss of
425 (ss1:ss_rest) -> (ss1, ss_rest)
427 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
428 splitFunTy_maybe fun_ty
430 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
431 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
433 collect_args (Var v) depth
434 = fiddleCCall v `thenUs` \ v1 ->
435 let v2 = lookupVarEnv env v1 `orElse` v1 in
436 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
438 stricts = case idNewStrictness v of
439 StrictSig (DmdType _ demands _)
440 | listLengthCmp demands depth /= GT -> demands
441 -- length demands <= depth
443 -- If depth < length demands, then we have too few args to
444 -- satisfy strictness info so we have to ignore all the
445 -- strictness info, e.g. + (error "urk")
446 -- Here, we can't evaluate the arg strictly, because this
447 -- partial application might be seq'd
450 collect_args (Note (Coerce ty1 ty2) fun) depth
451 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
452 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
454 collect_args (Note note fun) depth
456 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
457 returnUs (Note note fun', hd, fun_ty, floats, ss)
459 -- non-variable fun, better let-bind it
460 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
461 -- since it is sure to be evaluated.
462 collect_args fun depth
463 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
464 newVar ty `thenUs` \ fn_id ->
465 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
466 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
470 ignore_note (CoreNote _) = True
471 ignore_note InlineCall = True
472 ignore_note InlineMe = True
473 ignore_note _other = False
474 -- We don't ignore SCCs, since they require some code generation
476 ------------------------------------------------------------------------------
477 -- Building the saturated syntax
478 -- ---------------------------------------------------------------------------
480 -- maybeSaturate deals with saturating primops and constructors
481 -- The type is the type of the entire application
482 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
483 maybeSaturate fn expr n_args ty
484 | hasNoBinding fn = saturate_it
485 | otherwise = returnUs expr
487 fn_arity = idArity fn
488 excess_arity = fn_arity - n_args
489 saturate_it = getUniquesUs `thenUs` \ us ->
490 returnUs (etaExpand excess_arity us expr ty)
492 -- ---------------------------------------------------------------------------
493 -- Precipitating the floating bindings
494 -- ---------------------------------------------------------------------------
496 floatRhs :: TopLevelFlag -> RecFlag
498 -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
499 -> UniqSM (OrdList FloatingBind, -- Floats out of this bind
500 CoreExpr) -- Final Rhs
502 floatRhs top_lvl is_rec bndr (floats, rhs)
503 | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
504 allLazy top_lvl is_rec floats -- at top level
505 = -- Why the test for allLazy?
506 -- v = f (x `divInt#` y)
507 -- we don't want to float the case, even if f has arity 2,
508 -- because floating the case would make it evaluated too early
510 -- Finally, eta-expand the RHS, for the benefit of the code gen
511 returnUs (floats, rhs)
514 -- Don't float; the RHS isn't a value
515 = mkBinds floats rhs `thenUs` \ rhs' ->
516 returnUs (nilOL, rhs')
518 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
519 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
520 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
521 -> UniqSM (OrdList FloatingBind)
523 mkLocalNonRec bndr dem floats rhs
524 | isUnLiftedType (idType bndr)
525 -- If this is an unlifted binding, we always make a case for it.
526 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
528 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
530 returnUs (floats `snocOL` float)
533 -- It's a strict let so we definitely float all the bindings
534 = let -- Don't make a case for a value binding,
535 -- even if it's strict. Otherwise we get
536 -- case (\x -> e) of ...!
537 float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
538 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
540 returnUs (floats `snocOL` float)
543 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
544 returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
547 bndr_ty = idType bndr
550 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
552 | isNilOL binds = returnUs body
553 | otherwise = deLam body `thenUs` \ body' ->
554 returnUs (foldrOL mk_bind body' binds)
556 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
557 mk_bind (FloatLet bind) body = Let bind body
559 etaExpandRhs bndr rhs
560 = -- Eta expand to match the arity claimed by the binder
561 -- Remember, after CorePrep we must not change arity
563 -- Eta expansion might not have happened already,
564 -- because it is done by the simplifier only when
565 -- there at least one lambda already.
567 -- NB1:we could refrain when the RHS is trivial (which can happen
568 -- for exported things). This would reduce the amount of code
569 -- generated (a little) and make things a little words for
570 -- code compiled without -O. The case in point is data constructor
573 -- NB2: we have to be careful that the result of etaExpand doesn't
574 -- invalidate any of the assumptions that CorePrep is attempting
575 -- to establish. One possible cause is eta expanding inside of
576 -- an SCC note - we're now careful in etaExpand to make sure the
577 -- SCC is pushed inside any new lambdas that are generated.
579 -- NB3: It's important to do eta expansion, and *then* ANF-ising
580 -- f = /\a -> g (h 3) -- h has arity 2
581 -- If we ANF first we get
582 -- f = /\a -> let s = h 3 in g s
583 -- and now eta expansion gives
584 -- f = /\a -> \ y -> (let s = h 3 in g s) y
585 -- which is horrible.
586 -- Eta expanding first gives
587 -- f = /\a -> \y -> let s = h 3 in g s y
589 getUniquesUs `thenUs` \ us ->
590 returnUs (etaExpand arity us rhs (idType bndr))
592 -- For a GlobalId, take the Arity from the Id.
593 -- It was set in CoreTidy and must not change
594 -- For all others, just expand at will
595 arity | isGlobalId bndr = idArity bndr
596 | otherwise = exprArity rhs
598 -- ---------------------------------------------------------------------------
599 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
600 -- We arrange that they only show up as the RHS of a let(rec)
601 -- ---------------------------------------------------------------------------
603 deLam :: CoreExpr -> UniqSM CoreExpr
605 deLamFloat expr `thenUs` \ (floats, expr) ->
609 deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
610 -- Remove top level lambdas by let-bindinig
612 deLamFloat (Note n expr)
613 = -- You can get things like
614 -- case e of { p -> coerce t (\s -> ...) }
615 deLamFloat expr `thenUs` \ (floats, expr') ->
616 returnUs (floats, Note n expr')
619 | null bndrs = returnUs (nilOL, expr)
621 = case tryEta bndrs body of
622 Just no_lam_result -> returnUs (nilOL, no_lam_result)
623 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
624 returnUs (unitOL (FloatLet (NonRec fn expr)),
627 (bndrs,body) = collectBinders expr
629 -- Why try eta reduction? Hasn't the simplifier already done eta?
630 -- But the simplifier only eta reduces if that leaves something
631 -- trivial (like f, or f Int). But for deLam it would be enough to
632 -- get to a partial application, like (map f).
634 tryEta bndrs expr@(App _ _)
635 | ok_to_eta_reduce f &&
637 and (zipWith ok bndrs last_args) &&
638 not (any (`elemVarSet` fvs_remaining) bndrs)
639 = Just remaining_expr
641 (f, args) = collectArgs expr
642 remaining_expr = mkApps f remaining_args
643 fvs_remaining = exprFreeVars remaining_expr
644 (remaining_args, last_args) = splitAt n_remaining args
645 n_remaining = length args - length bndrs
647 ok bndr (Var arg) = bndr == arg
648 ok bndr other = False
650 -- we can't eta reduce something which must be saturated.
651 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
652 ok_to_eta_reduce _ = False --safe. ToDo: generalise
654 tryEta bndrs (Let bind@(NonRec b r) body)
655 | not (any (`elemVarSet` fvs) bndrs)
656 = case tryEta bndrs body of
657 Just e -> Just (Let bind e)
662 tryEta bndrs _ = Nothing
666 -- -----------------------------------------------------------------------------
668 -- -----------------------------------------------------------------------------
672 = RhsDemand { isStrict :: Bool, -- True => used at least once
673 isOnceDem :: Bool -- True => used at most once
676 mkDem :: Demand -> Bool -> RhsDemand
677 mkDem strict once = RhsDemand (isStrictDmd strict) once
679 mkDemTy :: Demand -> Type -> RhsDemand
680 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
683 bdrDem :: Id -> RhsDemand
684 bdrDem id = mkDem (idNewDemandInfo id)
687 -- safeDem :: RhsDemand
688 -- safeDem = RhsDemand False False -- always safe to use this
691 onceDem = RhsDemand False True -- used at most once
697 %************************************************************************
701 %************************************************************************
704 ------------------------------------------------------------------------------
706 -- ---------------------------------------------------------------------------
708 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
709 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
711 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
714 = getUniqueUs `thenUs` \ uniq ->
716 bndr' = setVarUnique bndr uniq
718 returnUs (extendVarEnv env bndr bndr', bndr')
720 | otherwise -- Top level things, which we don't want
721 -- to clone, have become GlobalIds by now
722 -- And we don't clone tyvars
723 = returnUs (env, bndr)
726 ------------------------------------------------------------------------------
727 -- Cloning ccall Ids; each must have a unique name,
728 -- to give the code generator a handle to hang it on
729 -- ---------------------------------------------------------------------------
731 fiddleCCall :: Id -> UniqSM Id
733 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
734 returnUs (id `setVarUnique` uniq)
735 | otherwise = returnUs id
737 ------------------------------------------------------------------------------
738 -- Generating new binders
739 -- ---------------------------------------------------------------------------
741 newVar :: Type -> UniqSM Id
744 getUniqueUs `thenUs` \ uniq ->
745 returnUs (mkSysLocal FSLIT("sat") uniq ty)