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, exprIsHNF, etaExpand, exprArity, exprOkForSpeculation )
14 import CoreFVs ( exprFreeVars )
15 import CoreLint ( endPass )
17 import Type ( Type, applyTy,
18 splitFunTy_maybe, isUnLiftedType, isUnboxedTupleType, seqType )
19 import Coercion ( coercionKind )
20 import TyCon ( TyCon, tyConDataCons )
21 import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
22 import Var ( Var, Id, setVarUnique )
25 import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding,
26 isFCallId, isGlobalId, isLocalId, hasNoBinding, idNewStrictness,
29 import DataCon ( dataConWorkId )
30 import PrimOp ( PrimOp( DataToTagOp ) )
31 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
39 import Util ( listLengthCmp )
43 -- ---------------------------------------------------------------------------
45 -- ---------------------------------------------------------------------------
47 The goal of this pass is to prepare for code generation.
49 1. Saturate constructor and primop applications.
51 2. Convert to A-normal form; that is, function arguments
54 * Use case for strict arguments:
55 f E ==> case E of x -> f x
58 * Use let for non-trivial lazy arguments
59 f E ==> let x = E in f x
60 (were f is lazy and x is non-trivial)
62 3. Similarly, convert any unboxed lets into cases.
63 [I'm experimenting with leaving 'ok-for-speculation'
64 rhss in let-form right up to this point.]
66 4. Ensure that lambdas only occur as the RHS of a binding
67 (The code generator can't deal with anything else.)
69 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
71 6. Clone all local Ids.
72 This means that all such Ids are unique, rather than the
73 weaker guarantee of no clashes which the simplifier provides.
74 And that is what the code generator needs.
76 We don't clone TyVars. The code gen doesn't need that,
77 and doing so would be tiresome because then we'd need
78 to substitute in types.
81 7. Give each dynamic CCall occurrence a fresh unique; this is
82 rather like the cloning step above.
84 8. Inject bindings for the "implicit" Ids:
85 * Constructor wrappers
88 We want curried definitions for all of these in case they
89 aren't inlined by some caller.
91 This is all done modulo type applications and abstractions, so that
92 when type erasure is done for conversion to STG, we don't end up with
93 any trivial or useless bindings.
97 -- -----------------------------------------------------------------------------
99 -- -----------------------------------------------------------------------------
102 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
103 corePrepPgm dflags binds data_tycons
104 = do showPass dflags "CorePrep"
105 us <- mkSplitUniqSupply 's'
107 let implicit_binds = mkDataConWorkers data_tycons
108 -- NB: we must feed mkImplicitBinds through corePrep too
109 -- so that they are suitably cloned and eta-expanded
111 binds_out = initUs_ us (
112 corePrepTopBinds binds `thenUs` \ floats1 ->
113 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
114 returnUs (deFloatTop (floats1 `appendFloats` floats2))
117 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
120 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
121 corePrepExpr dflags expr
122 = do showPass dflags "CorePrep"
123 us <- mkSplitUniqSupply 's'
124 let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
125 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
130 -- -----------------------------------------------------------------------------
132 -- -----------------------------------------------------------------------------
134 Create any necessary "implicit" bindings for data con workers. We
135 create the rather strange (non-recursive!) binding
137 $wC = \x y -> $wC x y
139 i.e. a curried constructor that allocates. This means that we can
140 treat the worker for a constructor like any other function in the rest
141 of the compiler. The point here is that CoreToStg will generate a
142 StgConApp for the RHS, rather than a call to the worker (which would
143 give a loop). As Lennart says: the ice is thin here, but it works.
145 Hmm. Should we create bindings for dictionary constructors? They are
146 always fully applied, and the bindings are just there to support
147 partial applications. But it's easier to let them through.
150 mkDataConWorkers data_tycons
151 = [ NonRec id (Var id) -- The ice is thin here, but it works
152 | tycon <- data_tycons, -- CorePrep will eta-expand it
153 data_con <- tyConDataCons tycon,
154 let id = dataConWorkId data_con ]
159 -- ---------------------------------------------------------------------------
160 -- Dealing with bindings
161 -- ---------------------------------------------------------------------------
163 data FloatingBind = FloatLet CoreBind
164 | FloatCase Id CoreExpr Bool
165 -- The bool indicates "ok-for-speculation"
167 data Floats = Floats OkToSpec (OrdList FloatingBind)
169 -- Can we float these binds out of the rhs of a let? We cache this decision
170 -- to avoid having to recompute it in a non-linear way when there are
171 -- deeply nested lets.
173 = NotOkToSpec -- definitely not
175 | IfUnboxedOk -- only if floating an unboxed binding is ok
177 emptyFloats :: Floats
178 emptyFloats = Floats OkToSpec nilOL
180 addFloat :: Floats -> FloatingBind -> Floats
181 addFloat (Floats ok_to_spec floats) new_float
182 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
184 check (FloatLet _) = OkToSpec
185 check (FloatCase _ _ ok_for_spec)
186 | ok_for_spec = IfUnboxedOk
187 | otherwise = NotOkToSpec
188 -- The ok-for-speculation flag says that it's safe to
189 -- float this Case out of a let, and thereby do it more eagerly
190 -- We need the top-level flag because it's never ok to float
191 -- an unboxed binding to the top level
193 unitFloat :: FloatingBind -> Floats
194 unitFloat = addFloat emptyFloats
196 appendFloats :: Floats -> Floats -> Floats
197 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
198 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
200 concatFloats :: [Floats] -> Floats
201 concatFloats = foldr appendFloats emptyFloats
203 combine NotOkToSpec _ = NotOkToSpec
204 combine _ NotOkToSpec = NotOkToSpec
205 combine IfUnboxedOk _ = IfUnboxedOk
206 combine _ IfUnboxedOk = IfUnboxedOk
207 combine _ _ = OkToSpec
209 instance Outputable FloatingBind where
210 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
211 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
213 deFloatTop :: Floats -> [CoreBind]
214 -- For top level only; we don't expect any FloatCases
215 deFloatTop (Floats _ floats)
216 = foldrOL get [] floats
218 get (FloatLet b) bs = b:bs
219 get b bs = pprPanic "corePrepPgm" (ppr b)
221 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
222 allLazy top_lvl is_rec (Floats ok_to_spec _)
226 IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
228 -- ---------------------------------------------------------------------------
230 -- ---------------------------------------------------------------------------
232 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
233 corePrepTopBinds binds
234 = go emptyCorePrepEnv binds
236 go env [] = returnUs emptyFloats
237 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
238 go env' binds `thenUs` \ binds' ->
239 returnUs (bind' `appendFloats` binds')
241 -- NB: we do need to float out of top-level bindings
242 -- Consider x = length [True,False]
248 -- We return a *list* of bindings, because we may start with
250 -- where x is demanded, in which case we want to finish with
253 -- And then x will actually end up case-bound
255 -- What happens to the CafInfo on the floated bindings? By
256 -- default, all the CafInfos will be set to MayHaveCafRefs,
259 -- This might be pessimistic, because eg. s1 & s2
260 -- might not refer to any CAFs and the GC will end up doing
261 -- more traversal than is necessary, but it's still better
262 -- than not floating the bindings at all, because then
263 -- the GC would have to traverse the structure in the heap
264 -- instead. Given this, we decided not to try to get
265 -- the CafInfo on the floated bindings correct, because
266 -- it looks difficult.
268 --------------------------------
269 corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
270 corePrepTopBind env (NonRec bndr rhs)
271 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
272 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
273 returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
275 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
277 --------------------------------
278 corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
279 -- This one is used for *local* bindings
280 corePrepBind env (NonRec bndr rhs)
281 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
282 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
283 cloneBndr env bndr `thenUs` \ (_, bndr') ->
284 mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') ->
285 -- We want bndr'' in the envt, because it records
286 -- the evaluated-ness of the binder
287 returnUs (extendCorePrepEnv env bndr bndr'', floats')
289 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
291 --------------------------------
292 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
293 -> [(Id,CoreExpr)] -- Recursive bindings
294 -> UniqSM (CorePrepEnv, Floats)
295 -- Used for all recursive bindings, top level and otherwise
296 corePrepRecPairs lvl env pairs
297 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
298 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
299 returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
301 -- Flatten all the floats, and the currrent
302 -- group into a single giant Rec
303 flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
305 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
306 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
307 get b prs2 = pprPanic "corePrepRecPairs" (ppr b)
309 --------------------------------
310 corePrepRhs :: TopLevelFlag -> RecFlag
311 -> CorePrepEnv -> (Id, CoreExpr)
312 -> UniqSM (Floats, CoreExpr)
313 -- Used for top-level bindings, and local recursive bindings
314 corePrepRhs top_lvl is_rec env (bndr, rhs)
315 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
316 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
317 floatRhs top_lvl is_rec bndr floats_w_rhs
320 -- ---------------------------------------------------------------------------
321 -- Making arguments atomic (function args & constructor args)
322 -- ---------------------------------------------------------------------------
324 -- This is where we arrange that a non-trivial argument is let-bound
325 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
326 -> UniqSM (Floats, CoreArg)
327 corePrepArg env arg dem
328 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
329 if exprIsTrivial arg'
330 then returnUs (floats, arg')
331 else newVar (exprType arg') `thenUs` \ v ->
332 mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') ->
333 returnUs (floats', Var v')
335 -- version that doesn't consider an scc annotation to be trivial.
336 exprIsTrivial (Var v) = True
337 exprIsTrivial (Type _) = True
338 exprIsTrivial (Lit lit) = True
339 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
340 exprIsTrivial (Note (SCC _) e) = False
341 exprIsTrivial (Note _ e) = exprIsTrivial e
342 exprIsTrivial (Cast e co) = exprIsTrivial e
343 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
344 exprIsTrivial other = False
346 -- ---------------------------------------------------------------------------
347 -- Dealing with expressions
348 -- ---------------------------------------------------------------------------
350 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
351 corePrepAnExpr env expr
352 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
356 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
360 -- e = let bs in e' (semantically, that is!)
363 -- f (g x) ===> ([v = g x], f v)
365 corePrepExprFloat env (Var v)
366 = fiddleCCall v `thenUs` \ v1 ->
368 v2 = lookupCorePrepEnv env v1
370 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
372 corePrepExprFloat env expr@(Type _)
373 = returnUs (emptyFloats, expr)
375 corePrepExprFloat env expr@(Lit lit)
376 = returnUs (emptyFloats, expr)
378 corePrepExprFloat env (Let bind body)
379 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
380 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
381 returnUs (new_binds `appendFloats` floats, new_body)
383 corePrepExprFloat env (Note n@(SCC _) expr)
384 = corePrepAnExpr env expr `thenUs` \ expr1 ->
385 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
386 returnUs (floats, Note n expr2)
388 corePrepExprFloat env (Note other_note expr)
389 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
390 returnUs (floats, Note other_note expr')
392 corePrepExprFloat env (Cast expr co)
393 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
394 returnUs (floats, Cast expr' co)
396 corePrepExprFloat env expr@(Lam _ _)
397 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
398 corePrepAnExpr env' body `thenUs` \ body' ->
399 returnUs (emptyFloats, mkLams bndrs' body')
401 (bndrs,body) = collectBinders expr
403 corePrepExprFloat env (Case scrut bndr ty alts)
404 = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
405 deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
407 bndr1 = bndr `setIdUnfolding` evaldUnfolding
408 -- Record that the case binder is evaluated in the alternatives
410 cloneBndr env bndr1 `thenUs` \ (env', bndr2) ->
411 mapUs (sat_alt env') alts `thenUs` \ alts' ->
412 returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
414 sat_alt env (con, bs, rhs)
415 = cloneBndrs env bs `thenUs` \ (env2, bs') ->
416 corePrepAnExpr env2 rhs `thenUs` \ rhs1 ->
417 deLam rhs1 `thenUs` \ rhs2 ->
418 returnUs (con, bs', rhs2)
420 corePrepExprFloat env expr@(App _ _)
421 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
422 ASSERT(null ss) -- make sure we used all the strictness info
424 -- Now deal with the function
426 Var fn_id -> maybeSaturate fn_id app depth floats ty
427 _other -> returnUs (floats, app)
431 -- Deconstruct and rebuild the application, floating any non-atomic
432 -- arguments to the outside. We collect the type of the expression,
433 -- the head of the application, and the number of actual value arguments,
434 -- all of which are used to possibly saturate this application if it
435 -- has a constructor or primop at the head.
439 -> Int -- current app depth
440 -> UniqSM (CoreExpr, -- the rebuilt expression
441 (CoreExpr,Int), -- the head of the application,
442 -- and no. of args it was applied to
443 Type, -- type of the whole expr
444 Floats, -- any floats we pulled out
445 [Demand]) -- remaining argument demands
447 collect_args (App fun arg@(Type arg_ty)) depth
448 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
449 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
451 collect_args (App fun arg) depth
452 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
454 (ss1, ss_rest) = case ss of
455 (ss1:ss_rest) -> (ss1, ss_rest)
457 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
458 splitFunTy_maybe fun_ty
460 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
461 returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
463 collect_args (Var v) depth
464 = fiddleCCall v `thenUs` \ v1 ->
466 v2 = lookupCorePrepEnv env v1
468 returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
470 stricts = case idNewStrictness v of
471 StrictSig (DmdType _ demands _)
472 | listLengthCmp demands depth /= GT -> demands
473 -- length demands <= depth
475 -- If depth < length demands, then we have too few args to
476 -- satisfy strictness info so we have to ignore all the
477 -- strictness info, e.g. + (error "urk")
478 -- Here, we can't evaluate the arg strictly, because this
479 -- partial application might be seq'd
481 collect_args (Cast fun co) depth
482 = let (_ty1,ty2) = coercionKind co in
483 collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
484 returnUs (Cast fun' co, hd, ty2, floats, ss)
486 collect_args (Note note fun) depth
487 | ignore_note note -- Drop these notes altogether
488 -- They aren't used by the code generator
489 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
490 returnUs (fun', hd, fun_ty, floats, ss)
492 -- N-variable fun, better let-bind it
493 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
494 -- since it is sure to be evaluated.
495 collect_args fun depth
496 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
497 newVar ty `thenUs` \ fn_id ->
498 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') ->
499 returnUs (Var fn_id', (Var fn_id', depth), ty, floats, [])
503 ignore_note (CoreNote _) = True
504 ignore_note InlineMe = True
505 ignore_note _other = False
506 -- We don't ignore SCCs, since they require some code generation
508 ------------------------------------------------------------------------------
509 -- Building the saturated syntax
510 -- ---------------------------------------------------------------------------
512 -- maybeSaturate deals with saturating primops and constructors
513 -- The type is the type of the entire application
514 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
515 maybeSaturate fn expr n_args floats ty
516 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
517 -- A gruesome special case
518 = saturate_it `thenUs` \ sat_expr ->
520 -- OK, now ensure that the arg is evaluated.
521 -- But (sigh) take into account the lambdas we've now introduced
523 (eta_bndrs, eta_body) = collectBinders sat_expr
525 eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') ->
526 if null eta_bndrs then
527 returnUs (floats `appendFloats` eta_floats, eta_body')
529 mkBinds eta_floats eta_body' `thenUs` \ eta_body'' ->
530 returnUs (floats, mkLams eta_bndrs eta_body'')
532 | hasNoBinding fn = saturate_it `thenUs` \ sat_expr ->
533 returnUs (floats, sat_expr)
535 | otherwise = returnUs (floats, expr)
538 fn_arity = idArity fn
539 excess_arity = fn_arity - n_args
541 saturate_it :: UniqSM CoreExpr
542 saturate_it | excess_arity == 0 = returnUs expr
543 | otherwise = getUniquesUs `thenUs` \ us ->
544 returnUs (etaExpand excess_arity us expr ty)
546 -- Ensure that the argument of DataToTagOp is evaluated
547 eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
548 eval_data2tag_arg app@(fun `App` arg)
549 | exprIsHNF arg -- Includes nullary constructors
550 = returnUs (emptyFloats, app) -- The arg is evaluated
551 | otherwise -- Arg not evaluated, so evaluate it
552 = newVar (exprType arg) `thenUs` \ arg_id ->
554 arg_id1 = setIdUnfolding arg_id evaldUnfolding
556 returnUs (unitFloat (FloatCase arg_id1 arg False ),
557 fun `App` Var arg_id1)
559 eval_data2tag_arg (Note note app) -- Scc notes can appear
560 = eval_data2tag_arg app `thenUs` \ (floats, app') ->
561 returnUs (floats, Note note app')
563 eval_data2tag_arg other -- Should not happen
564 = pprPanic "eval_data2tag" (ppr other)
567 -- ---------------------------------------------------------------------------
568 -- Precipitating the floating bindings
569 -- ---------------------------------------------------------------------------
571 floatRhs :: TopLevelFlag -> RecFlag
573 -> (Floats, CoreExpr) -- Rhs: let binds in body
574 -> UniqSM (Floats, -- Floats out of this bind
575 CoreExpr) -- Final Rhs
577 floatRhs top_lvl is_rec bndr (floats, rhs)
578 | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
579 allLazy top_lvl is_rec floats -- at top level
580 = -- Why the test for allLazy?
581 -- v = f (x `divInt#` y)
582 -- we don't want to float the case, even if f has arity 2,
583 -- because floating the case would make it evaluated too early
584 returnUs (floats, rhs)
587 -- Don't float; the RHS isn't a value
588 = mkBinds floats rhs `thenUs` \ rhs' ->
589 returnUs (emptyFloats, rhs')
591 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
592 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
593 -> Floats -> CoreExpr -- Rhs: let binds in body
594 -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
595 -- to record that it's been evaluated
597 mkLocalNonRec bndr dem floats rhs
598 | isUnLiftedType (idType bndr)
599 -- If this is an unlifted binding, we always make a case for it.
600 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
602 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
604 returnUs (addFloat floats float, evald_bndr)
607 -- It's a strict let so we definitely float all the bindings
608 = let -- Don't make a case for a value binding,
609 -- even if it's strict. Otherwise we get
610 -- case (\x -> e) of ...!
611 float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
612 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
614 returnUs (addFloat floats float, evald_bndr)
617 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
618 returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
619 if exprIsHNF rhs' then evald_bndr else bndr)
622 evald_bndr = bndr `setIdUnfolding` evaldUnfolding
623 -- Record if the binder is evaluated
626 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
627 mkBinds (Floats _ binds) body
628 | isNilOL binds = returnUs body
629 | otherwise = deLam body `thenUs` \ body' ->
630 -- Lambdas are not allowed as the body of a 'let'
631 returnUs (foldrOL mk_bind body' binds)
633 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
634 mk_bind (FloatLet bind) body = Let bind body
636 etaExpandRhs bndr rhs
637 = -- Eta expand to match the arity claimed by the binder
638 -- Remember, after CorePrep we must not change arity
640 -- Eta expansion might not have happened already,
641 -- because it is done by the simplifier only when
642 -- there at least one lambda already.
644 -- NB1:we could refrain when the RHS is trivial (which can happen
645 -- for exported things). This would reduce the amount of code
646 -- generated (a little) and make things a little words for
647 -- code compiled without -O. The case in point is data constructor
650 -- NB2: we have to be careful that the result of etaExpand doesn't
651 -- invalidate any of the assumptions that CorePrep is attempting
652 -- to establish. One possible cause is eta expanding inside of
653 -- an SCC note - we're now careful in etaExpand to make sure the
654 -- SCC is pushed inside any new lambdas that are generated.
656 -- NB3: It's important to do eta expansion, and *then* ANF-ising
657 -- f = /\a -> g (h 3) -- h has arity 2
658 -- If we ANF first we get
659 -- f = /\a -> let s = h 3 in g s
660 -- and now eta expansion gives
661 -- f = /\a -> \ y -> (let s = h 3 in g s) y
662 -- which is horrible.
663 -- Eta expanding first gives
664 -- f = /\a -> \y -> let s = h 3 in g s y
666 getUniquesUs `thenUs` \ us ->
667 returnUs (etaExpand arity us rhs (idType bndr))
669 -- For a GlobalId, take the Arity from the Id.
670 -- It was set in CoreTidy and must not change
671 -- For all others, just expand at will
672 arity | isGlobalId bndr = idArity bndr
673 | otherwise = exprArity rhs
675 -- ---------------------------------------------------------------------------
676 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
677 -- We arrange that they only show up as the RHS of a let(rec)
678 -- ---------------------------------------------------------------------------
680 deLam :: CoreExpr -> UniqSM CoreExpr
681 -- Takes an expression that may be a lambda,
682 -- and returns one that definitely isn't:
683 -- (\x.e) ==> let f = \x.e in f
685 deLamFloat expr `thenUs` \ (floats, expr) ->
689 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
690 -- Remove top level lambdas by let-bindinig
692 deLamFloat (Note n expr)
693 = -- You can get things like
694 -- case e of { p -> coerce t (\s -> ...) }
695 deLamFloat expr `thenUs` \ (floats, expr') ->
696 returnUs (floats, Note n expr')
698 deLamFloat (Cast e co)
699 = deLamFloat e `thenUs` \ (floats, e') ->
700 returnUs (floats, Cast e' co)
703 | null bndrs = returnUs (emptyFloats, expr)
705 = case tryEta bndrs body of
706 Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
707 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
708 returnUs (unitFloat (FloatLet (NonRec fn expr)),
711 (bndrs,body) = collectBinders expr
713 -- Why try eta reduction? Hasn't the simplifier already done eta?
714 -- But the simplifier only eta reduces if that leaves something
715 -- trivial (like f, or f Int). But for deLam it would be enough to
716 -- get to a partial application:
717 -- \xs. map f xs ==> map f
719 tryEta bndrs expr@(App _ _)
720 | ok_to_eta_reduce f &&
722 and (zipWith ok bndrs last_args) &&
723 not (any (`elemVarSet` fvs_remaining) bndrs)
724 = Just remaining_expr
726 (f, args) = collectArgs expr
727 remaining_expr = mkApps f remaining_args
728 fvs_remaining = exprFreeVars remaining_expr
729 (remaining_args, last_args) = splitAt n_remaining args
730 n_remaining = length args - length bndrs
732 ok bndr (Var arg) = bndr == arg
733 ok bndr other = False
735 -- we can't eta reduce something which must be saturated.
736 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
737 ok_to_eta_reduce _ = False --safe. ToDo: generalise
739 tryEta bndrs (Let bind@(NonRec b r) body)
740 | not (any (`elemVarSet` fvs) bndrs)
741 = case tryEta bndrs body of
742 Just e -> Just (Let bind e)
747 tryEta bndrs _ = Nothing
751 -- -----------------------------------------------------------------------------
753 -- -----------------------------------------------------------------------------
757 = RhsDemand { isStrict :: Bool, -- True => used at least once
758 isOnceDem :: Bool -- True => used at most once
761 mkDem :: Demand -> Bool -> RhsDemand
762 mkDem strict once = RhsDemand (isStrictDmd strict) once
764 mkDemTy :: Demand -> Type -> RhsDemand
765 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
768 bdrDem :: Id -> RhsDemand
769 bdrDem id = mkDem (idNewDemandInfo id)
772 -- safeDem :: RhsDemand
773 -- safeDem = RhsDemand False False -- always safe to use this
776 onceDem = RhsDemand False True -- used at most once
782 %************************************************************************
786 %************************************************************************
789 -- ---------------------------------------------------------------------------
791 -- ---------------------------------------------------------------------------
793 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
795 emptyCorePrepEnv :: CorePrepEnv
796 emptyCorePrepEnv = CPE emptyVarEnv
798 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
799 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
801 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
802 lookupCorePrepEnv (CPE env) id
803 = case lookupVarEnv env id of
807 ------------------------------------------------------------------------------
809 -- ---------------------------------------------------------------------------
811 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
812 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
814 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
817 = getUniqueUs `thenUs` \ uniq ->
819 bndr' = setVarUnique bndr uniq
821 returnUs (extendCorePrepEnv env bndr bndr', bndr')
823 | otherwise -- Top level things, which we don't want
824 -- to clone, have become GlobalIds by now
825 -- And we don't clone tyvars
826 = returnUs (env, bndr)
829 ------------------------------------------------------------------------------
830 -- Cloning ccall Ids; each must have a unique name,
831 -- to give the code generator a handle to hang it on
832 -- ---------------------------------------------------------------------------
834 fiddleCCall :: Id -> UniqSM Id
836 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
837 returnUs (id `setVarUnique` uniq)
838 | otherwise = returnUs id
840 ------------------------------------------------------------------------------
841 -- Generating new binders
842 -- ---------------------------------------------------------------------------
844 newVar :: Type -> UniqSM Id
847 getUniqueUs `thenUs` \ uniq ->
848 returnUs (mkSysLocal FSLIT("sat") uniq ty)