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, isImplicitId,
25 isLocalId, hasNoBinding, idNewStrictness,
26 idUnfolding, isDataConWorkId_maybe
28 import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) )
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 -> [CoreBind] -> TypeEnv -> IO [CoreBind]
100 corePrepPgm dflags binds types
101 = do showPass dflags "CorePrep"
102 us <- mkSplitUniqSupply 's'
104 let implicit_binds = mkImplicitBinds types
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 binds `thenUs` \ floats1 ->
110 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
111 returnUs (deFloatTop (floats1 `appendFloats` floats2))
114 endPass dflags "CorePrep" Opt_D_dump_prep 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 | AnId id <- typeEnvElts type_env, isImplicitId id ]
158 -- The type environment already contains all the implicit Ids,
159 -- so we just filter them out
161 -- The etaExpand is so that the manifest arity of the
162 -- binding matches its claimed arity, which is an
163 -- invariant of top level bindings going into the code gen
165 get_unfolding id -- See notes above
166 | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works
167 -- CorePrep will eta-expand it
168 | otherwise = unfoldingTemplate (idUnfolding id)
173 -- ---------------------------------------------------------------------------
174 -- Dealing with bindings
175 -- ---------------------------------------------------------------------------
177 data FloatingBind = FloatLet CoreBind
178 | FloatCase Id CoreExpr Bool
179 -- The bool indicates "ok-for-speculation"
181 data Floats = Floats OkToSpec (OrdList FloatingBind)
183 -- Can we float these binds out of the rhs of a let? We cache this decision
184 -- to avoid having to recompute it in a non-linear way when there are
185 -- deeply nested lets.
187 = NotOkToSpec -- definitely not
189 | IfUnboxedOk -- only if floating an unboxed binding is ok
191 emptyFloats :: Floats
192 emptyFloats = Floats OkToSpec nilOL
194 addFloat :: Floats -> FloatingBind -> Floats
195 addFloat (Floats ok_to_spec floats) new_float
196 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
198 check (FloatLet _) = OkToSpec
199 check (FloatCase _ _ ok_for_spec)
200 | ok_for_spec = IfUnboxedOk
201 | otherwise = NotOkToSpec
202 -- The ok-for-speculation flag says that it's safe to
203 -- float this Case out of a let, and thereby do it more eagerly
204 -- We need the top-level flag because it's never ok to float
205 -- an unboxed binding to the top level
207 unitFloat :: FloatingBind -> Floats
208 unitFloat = addFloat emptyFloats
210 appendFloats :: Floats -> Floats -> Floats
211 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
212 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
214 concatFloats :: [Floats] -> Floats
215 concatFloats = foldr appendFloats emptyFloats
217 combine NotOkToSpec _ = NotOkToSpec
218 combine _ NotOkToSpec = NotOkToSpec
219 combine IfUnboxedOk _ = IfUnboxedOk
220 combine _ IfUnboxedOk = IfUnboxedOk
221 combine _ _ = OkToSpec
223 instance Outputable FloatingBind where
224 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
225 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
227 type CloneEnv = IdEnv Id -- Clone local Ids
229 deFloatTop :: Floats -> [CoreBind]
230 -- For top level only; we don't expect any FloatCases
231 deFloatTop (Floats _ floats)
232 = foldrOL get [] floats
234 get (FloatLet b) bs = b:bs
235 get b bs = pprPanic "corePrepPgm" (ppr b)
237 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
238 allLazy top_lvl is_rec (Floats ok_to_spec _)
242 IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
244 -- ---------------------------------------------------------------------------
246 -- ---------------------------------------------------------------------------
248 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
249 corePrepTopBinds binds
250 = go emptyVarEnv binds
252 go env [] = returnUs emptyFloats
253 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
254 go env' binds `thenUs` \ binds' ->
255 returnUs (bind' `appendFloats` binds')
257 -- NB: we do need to float out of top-level bindings
258 -- Consider x = length [True,False]
264 -- We return a *list* of bindings, because we may start with
266 -- where x is demanded, in which case we want to finish with
269 -- And then x will actually end up case-bound
271 -- What happens to the CafInfo on the floated bindings? By
272 -- default, all the CafInfos will be set to MayHaveCafRefs,
275 -- This might be pessimistic, because eg. s1 & s2
276 -- might not refer to any CAFs and the GC will end up doing
277 -- more traversal than is necessary, but it's still better
278 -- than not floating the bindings at all, because then
279 -- the GC would have to traverse the structure in the heap
280 -- instead. Given this, we decided not to try to get
281 -- the CafInfo on the floated bindings correct, because
282 -- it looks difficult.
284 --------------------------------
285 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats)
286 corePrepTopBind env (NonRec bndr rhs)
287 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
288 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
289 returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
291 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
293 --------------------------------
294 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats)
295 -- This one is used for *local* bindings
296 corePrepBind env (NonRec bndr rhs)
297 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
298 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
299 cloneBndr env bndr `thenUs` \ (env', bndr') ->
300 mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
301 returnUs (env', floats')
303 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
305 --------------------------------
306 corePrepRecPairs :: TopLevelFlag -> CloneEnv
307 -> [(Id,CoreExpr)] -- Recursive bindings
308 -> UniqSM (CloneEnv, Floats)
309 -- Used for all recursive bindings, top level and otherwise
310 corePrepRecPairs lvl env pairs
311 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
312 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
313 returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
315 -- Flatten all the floats, and the currrent
316 -- group into a single giant Rec
317 flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
319 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
320 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
322 --------------------------------
323 corePrepRhs :: TopLevelFlag -> RecFlag
324 -> CloneEnv -> (Id, CoreExpr)
325 -> UniqSM (Floats, CoreExpr)
326 -- Used for top-level bindings, and local recursive bindings
327 corePrepRhs top_lvl is_rec env (bndr, rhs)
328 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
329 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
330 floatRhs top_lvl is_rec bndr floats_w_rhs
333 -- ---------------------------------------------------------------------------
334 -- Making arguments atomic (function args & constructor args)
335 -- ---------------------------------------------------------------------------
337 -- This is where we arrange that a non-trivial argument is let-bound
338 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
339 -> UniqSM (Floats, CoreArg)
340 corePrepArg env arg dem
341 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
342 if exprIsTrivial arg'
343 then returnUs (floats, arg')
344 else newVar (exprType arg') `thenUs` \ v ->
345 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
346 returnUs (floats', Var v)
348 -- version that doesn't consider an scc annotation to be trivial.
349 exprIsTrivial (Var v) = True
350 exprIsTrivial (Type _) = True
351 exprIsTrivial (Lit lit) = True
352 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
353 exprIsTrivial (Note (SCC _) e) = False
354 exprIsTrivial (Note _ e) = exprIsTrivial e
355 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
356 exprIsTrivial other = False
358 -- ---------------------------------------------------------------------------
359 -- Dealing with expressions
360 -- ---------------------------------------------------------------------------
362 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
363 corePrepAnExpr env expr
364 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
368 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
372 -- e = let bs in e' (semantically, that is!)
375 -- f (g x) ===> ([v = g x], f v)
377 corePrepExprFloat env (Var v)
378 = fiddleCCall v `thenUs` \ v1 ->
379 let v2 = lookupVarEnv env v1 `orElse` v1 in
380 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
381 returnUs (emptyFloats, app)
383 corePrepExprFloat env expr@(Type _)
384 = returnUs (emptyFloats, expr)
386 corePrepExprFloat env expr@(Lit lit)
387 = returnUs (emptyFloats, expr)
389 corePrepExprFloat env (Let bind body)
390 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
391 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
392 returnUs (new_binds `appendFloats` floats, new_body)
394 corePrepExprFloat env (Note n@(SCC _) expr)
395 = corePrepAnExpr env expr `thenUs` \ expr1 ->
396 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
397 returnUs (floats, Note n expr2)
399 corePrepExprFloat env (Note other_note expr)
400 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
401 returnUs (floats, Note other_note expr')
403 corePrepExprFloat env expr@(Lam _ _)
404 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
405 corePrepAnExpr env' body `thenUs` \ body' ->
406 returnUs (emptyFloats, mkLams bndrs' body')
408 (bndrs,body) = collectBinders expr
411 corePrepExprFloat env (Case scrut bndr ty alts)
412 = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
413 deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
414 cloneBndr env bndr `thenUs` \ (env', bndr') ->
415 mapUs (sat_alt env') alts `thenUs` \ alts' ->
417 returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' ty alts')
419 sat_alt env (con, bs, rhs)
420 = cloneBndrs env bs `thenUs` \ (env', bs') ->
421 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
422 deLam rhs1 `thenUs` \ rhs2 ->
423 returnUs (con, bs', rhs2)
425 corePrepExprFloat env expr@(App _ _)
426 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
427 ASSERT(null ss) -- make sure we used all the strictness info
429 -- Now deal with the function
431 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
432 returnUs (floats, app')
434 _other -> returnUs (floats, app)
438 -- Deconstruct and rebuild the application, floating any non-atomic
439 -- arguments to the outside. We collect the type of the expression,
440 -- the head of the application, and the number of actual value arguments,
441 -- all of which are used to possibly saturate this application if it
442 -- has a constructor or primop at the head.
446 -> Int -- current app depth
447 -> UniqSM (CoreExpr, -- the rebuilt expression
448 (CoreExpr,Int), -- the head of the application,
449 -- and no. of args it was applied to
450 Type, -- type of the whole expr
451 Floats, -- any floats we pulled out
452 [Demand]) -- remaining argument demands
454 collect_args (App fun arg@(Type arg_ty)) depth
455 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
456 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
458 collect_args (App fun arg) depth
459 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
461 (ss1, ss_rest) = case ss of
462 (ss1:ss_rest) -> (ss1, ss_rest)
464 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
465 splitFunTy_maybe fun_ty
467 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
468 returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
470 collect_args (Var v) depth
471 = fiddleCCall v `thenUs` \ v1 ->
472 let v2 = lookupVarEnv env v1 `orElse` v1 in
473 returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
475 stricts = case idNewStrictness v of
476 StrictSig (DmdType _ demands _)
477 | listLengthCmp demands depth /= GT -> demands
478 -- length demands <= depth
480 -- If depth < length demands, then we have too few args to
481 -- satisfy strictness info so we have to ignore all the
482 -- strictness info, e.g. + (error "urk")
483 -- Here, we can't evaluate the arg strictly, because this
484 -- partial application might be seq'd
487 collect_args (Note (Coerce ty1 ty2) fun) depth
488 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
489 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
491 collect_args (Note note fun) depth
493 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
494 returnUs (Note note fun', hd, fun_ty, floats, ss)
496 -- non-variable fun, better let-bind it
497 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
498 -- since it is sure to be evaluated.
499 collect_args fun depth
500 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
501 newVar ty `thenUs` \ fn_id ->
502 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
503 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
507 ignore_note (CoreNote _) = True
508 ignore_note InlineCall = True
509 ignore_note InlineMe = True
510 ignore_note _other = False
511 -- We don't ignore SCCs, since they require some code generation
513 ------------------------------------------------------------------------------
514 -- Building the saturated syntax
515 -- ---------------------------------------------------------------------------
517 -- maybeSaturate deals with saturating primops and constructors
518 -- The type is the type of the entire application
519 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
520 maybeSaturate fn expr n_args ty
521 | hasNoBinding fn = saturate_it
522 | otherwise = returnUs expr
524 fn_arity = idArity fn
525 excess_arity = fn_arity - n_args
526 saturate_it = getUniquesUs `thenUs` \ us ->
527 returnUs (etaExpand excess_arity us expr ty)
529 -- ---------------------------------------------------------------------------
530 -- Precipitating the floating bindings
531 -- ---------------------------------------------------------------------------
533 floatRhs :: TopLevelFlag -> RecFlag
535 -> (Floats, CoreExpr) -- Rhs: let binds in body
536 -> UniqSM (Floats, -- Floats out of this bind
537 CoreExpr) -- Final Rhs
539 floatRhs top_lvl is_rec bndr (floats, rhs)
540 | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
541 allLazy top_lvl is_rec floats -- at top level
542 = -- Why the test for allLazy?
543 -- v = f (x `divInt#` y)
544 -- we don't want to float the case, even if f has arity 2,
545 -- because floating the case would make it evaluated too early
547 -- Finally, eta-expand the RHS, for the benefit of the code gen
548 returnUs (floats, rhs)
551 -- Don't float; the RHS isn't a value
552 = mkBinds floats rhs `thenUs` \ rhs' ->
553 returnUs (emptyFloats, rhs')
555 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
556 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
557 -> Floats -> CoreExpr -- Rhs: let binds in body
560 mkLocalNonRec bndr dem floats rhs
561 | isUnLiftedType (idType bndr)
562 -- If this is an unlifted binding, we always make a case for it.
563 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
565 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
567 returnUs (addFloat floats float)
570 -- It's a strict let so we definitely float all the bindings
571 = let -- Don't make a case for a value binding,
572 -- even if it's strict. Otherwise we get
573 -- case (\x -> e) of ...!
574 float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
575 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
577 returnUs (addFloat floats float)
580 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
581 returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')))
584 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
585 mkBinds (Floats _ binds) body
586 | isNilOL binds = returnUs body
587 | otherwise = deLam body `thenUs` \ body' ->
588 returnUs (foldrOL mk_bind body' binds)
591 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
592 mk_bind (FloatLet bind) body = Let bind body
594 etaExpandRhs bndr rhs
595 = -- Eta expand to match the arity claimed by the binder
596 -- Remember, after CorePrep we must not change arity
598 -- Eta expansion might not have happened already,
599 -- because it is done by the simplifier only when
600 -- there at least one lambda already.
602 -- NB1:we could refrain when the RHS is trivial (which can happen
603 -- for exported things). This would reduce the amount of code
604 -- generated (a little) and make things a little words for
605 -- code compiled without -O. The case in point is data constructor
608 -- NB2: we have to be careful that the result of etaExpand doesn't
609 -- invalidate any of the assumptions that CorePrep is attempting
610 -- to establish. One possible cause is eta expanding inside of
611 -- an SCC note - we're now careful in etaExpand to make sure the
612 -- SCC is pushed inside any new lambdas that are generated.
614 -- NB3: It's important to do eta expansion, and *then* ANF-ising
615 -- f = /\a -> g (h 3) -- h has arity 2
616 -- If we ANF first we get
617 -- f = /\a -> let s = h 3 in g s
618 -- and now eta expansion gives
619 -- f = /\a -> \ y -> (let s = h 3 in g s) y
620 -- which is horrible.
621 -- Eta expanding first gives
622 -- f = /\a -> \y -> let s = h 3 in g s y
624 getUniquesUs `thenUs` \ us ->
625 returnUs (etaExpand arity us rhs (idType bndr))
627 -- For a GlobalId, take the Arity from the Id.
628 -- It was set in CoreTidy and must not change
629 -- For all others, just expand at will
630 arity | isGlobalId bndr = idArity bndr
631 | otherwise = exprArity rhs
633 -- ---------------------------------------------------------------------------
634 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
635 -- We arrange that they only show up as the RHS of a let(rec)
636 -- ---------------------------------------------------------------------------
638 deLam :: CoreExpr -> UniqSM CoreExpr
640 deLamFloat expr `thenUs` \ (floats, expr) ->
644 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
645 -- Remove top level lambdas by let-bindinig
647 deLamFloat (Note n expr)
648 = -- You can get things like
649 -- case e of { p -> coerce t (\s -> ...) }
650 deLamFloat expr `thenUs` \ (floats, expr') ->
651 returnUs (floats, Note n expr')
654 | null bndrs = returnUs (emptyFloats, expr)
656 = case tryEta bndrs body of
657 Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
658 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
659 returnUs (unitFloat (FloatLet (NonRec fn expr)),
662 (bndrs,body) = collectBinders expr
664 -- Why try eta reduction? Hasn't the simplifier already done eta?
665 -- But the simplifier only eta reduces if that leaves something
666 -- trivial (like f, or f Int). But for deLam it would be enough to
667 -- get to a partial application, like (map f).
669 tryEta bndrs expr@(App _ _)
670 | ok_to_eta_reduce f &&
672 and (zipWith ok bndrs last_args) &&
673 not (any (`elemVarSet` fvs_remaining) bndrs)
674 = Just remaining_expr
676 (f, args) = collectArgs expr
677 remaining_expr = mkApps f remaining_args
678 fvs_remaining = exprFreeVars remaining_expr
679 (remaining_args, last_args) = splitAt n_remaining args
680 n_remaining = length args - length bndrs
682 ok bndr (Var arg) = bndr == arg
683 ok bndr other = False
685 -- we can't eta reduce something which must be saturated.
686 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
687 ok_to_eta_reduce _ = False --safe. ToDo: generalise
689 tryEta bndrs (Let bind@(NonRec b r) body)
690 | not (any (`elemVarSet` fvs) bndrs)
691 = case tryEta bndrs body of
692 Just e -> Just (Let bind e)
697 tryEta bndrs _ = Nothing
701 -- -----------------------------------------------------------------------------
703 -- -----------------------------------------------------------------------------
707 = RhsDemand { isStrict :: Bool, -- True => used at least once
708 isOnceDem :: Bool -- True => used at most once
711 mkDem :: Demand -> Bool -> RhsDemand
712 mkDem strict once = RhsDemand (isStrictDmd strict) once
714 mkDemTy :: Demand -> Type -> RhsDemand
715 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
718 bdrDem :: Id -> RhsDemand
719 bdrDem id = mkDem (idNewDemandInfo id)
722 -- safeDem :: RhsDemand
723 -- safeDem = RhsDemand False False -- always safe to use this
726 onceDem = RhsDemand False True -- used at most once
732 %************************************************************************
736 %************************************************************************
739 ------------------------------------------------------------------------------
741 -- ---------------------------------------------------------------------------
743 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
744 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
746 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
749 = getUniqueUs `thenUs` \ uniq ->
751 bndr' = setVarUnique bndr uniq
753 returnUs (extendVarEnv env bndr bndr', bndr')
755 | otherwise -- Top level things, which we don't want
756 -- to clone, have become GlobalIds by now
757 -- And we don't clone tyvars
758 = returnUs (env, bndr)
761 ------------------------------------------------------------------------------
762 -- Cloning ccall Ids; each must have a unique name,
763 -- to give the code generator a handle to hang it on
764 -- ---------------------------------------------------------------------------
766 fiddleCCall :: Id -> UniqSM Id
768 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
769 returnUs (id `setVarUnique` uniq)
770 | otherwise = returnUs id
772 ------------------------------------------------------------------------------
773 -- Generating new binders
774 -- ---------------------------------------------------------------------------
776 newVar :: Type -> UniqSM Id
779 getUniqueUs `thenUs` \ uniq ->
780 returnUs (mkSysLocal FSLIT("sat") uniq ty)