2 % (c) The University of Glasgow, 1994-2006
5 Core pass to saturate constructors and PrimOps
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 corePrepPgm, corePrepExpr
19 #include "HsVersions.h"
21 import CoreUtils hiding (exprIsTrivial)
47 -- ---------------------------------------------------------------------------
49 -- ---------------------------------------------------------------------------
51 The goal of this pass is to prepare for code generation.
53 1. Saturate constructor and primop applications.
55 2. Convert to A-normal form; that is, function arguments
58 * Use case for strict arguments:
59 f E ==> case E of x -> f x
62 * Use let for non-trivial lazy arguments
63 f E ==> let x = E in f x
64 (were f is lazy and x is non-trivial)
66 3. Similarly, convert any unboxed lets into cases.
67 [I'm experimenting with leaving 'ok-for-speculation'
68 rhss in let-form right up to this point.]
70 4. Ensure that lambdas only occur as the RHS of a binding
71 (The code generator can't deal with anything else.)
73 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
75 6. Clone all local Ids.
76 This means that all such Ids are unique, rather than the
77 weaker guarantee of no clashes which the simplifier provides.
78 And that is what the code generator needs.
80 We don't clone TyVars. The code gen doesn't need that,
81 and doing so would be tiresome because then we'd need
82 to substitute in types.
85 7. Give each dynamic CCall occurrence a fresh unique; this is
86 rather like the cloning step above.
88 8. Inject bindings for the "implicit" Ids:
89 * Constructor wrappers
92 We want curried definitions for all of these in case they
93 aren't inlined by some caller.
95 This is all done modulo type applications and abstractions, so that
96 when type erasure is done for conversion to STG, we don't end up with
97 any trivial or useless bindings.
101 -- -----------------------------------------------------------------------------
103 -- -----------------------------------------------------------------------------
106 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
107 corePrepPgm dflags binds data_tycons = do
108 showPass dflags "CorePrep"
109 us <- mkSplitUniqSupply 's'
111 let implicit_binds = mkDataConWorkers data_tycons
112 -- NB: we must feed mkImplicitBinds through corePrep too
113 -- so that they are suitably cloned and eta-expanded
115 binds_out = initUs_ us $ do
116 floats1 <- corePrepTopBinds binds
117 floats2 <- corePrepTopBinds implicit_binds
118 return (deFloatTop (floats1 `appendFloats` floats2))
120 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
123 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
124 corePrepExpr dflags expr = do
125 showPass dflags "CorePrep"
126 us <- mkSplitUniqSupply 's'
127 let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
128 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
132 -- -----------------------------------------------------------------------------
134 -- -----------------------------------------------------------------------------
136 Create any necessary "implicit" bindings for data con workers. We
137 create the rather strange (non-recursive!) binding
139 $wC = \x y -> $wC x y
141 i.e. a curried constructor that allocates. This means that we can
142 treat the worker for a constructor like any other function in the rest
143 of the compiler. The point here is that CoreToStg will generate a
144 StgConApp for the RHS, rather than a call to the worker (which would
145 give a loop). As Lennart says: the ice is thin here, but it works.
147 Hmm. Should we create bindings for dictionary constructors? They are
148 always fully applied, and the bindings are just there to support
149 partial applications. But it's easier to let them through.
152 mkDataConWorkers data_tycons
153 = [ NonRec id (Var id) -- The ice is thin here, but it works
154 | tycon <- data_tycons, -- CorePrep will eta-expand it
155 data_con <- tyConDataCons tycon,
156 let id = dataConWorkId data_con ]
161 -- ---------------------------------------------------------------------------
162 -- Dealing with bindings
163 -- ---------------------------------------------------------------------------
165 data FloatingBind = FloatLet CoreBind
166 | FloatCase Id CoreExpr Bool
167 -- The bool indicates "ok-for-speculation"
169 data Floats = Floats OkToSpec (OrdList FloatingBind)
171 -- Can we float these binds out of the rhs of a let? We cache this decision
172 -- to avoid having to recompute it in a non-linear way when there are
173 -- deeply nested lets.
175 = NotOkToSpec -- definitely not
177 | IfUnboxedOk -- only if floating an unboxed binding is ok
179 emptyFloats :: Floats
180 emptyFloats = Floats OkToSpec nilOL
182 addFloat :: Floats -> FloatingBind -> Floats
183 addFloat (Floats ok_to_spec floats) new_float
184 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
186 check (FloatLet _) = OkToSpec
187 check (FloatCase _ _ ok_for_spec)
188 | ok_for_spec = IfUnboxedOk
189 | otherwise = NotOkToSpec
190 -- The ok-for-speculation flag says that it's safe to
191 -- float this Case out of a let, and thereby do it more eagerly
192 -- We need the top-level flag because it's never ok to float
193 -- an unboxed binding to the top level
195 unitFloat :: FloatingBind -> Floats
196 unitFloat = addFloat emptyFloats
198 appendFloats :: Floats -> Floats -> Floats
199 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
200 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
202 concatFloats :: [Floats] -> Floats
203 concatFloats = foldr appendFloats emptyFloats
205 combine NotOkToSpec _ = NotOkToSpec
206 combine _ NotOkToSpec = NotOkToSpec
207 combine IfUnboxedOk _ = IfUnboxedOk
208 combine _ IfUnboxedOk = IfUnboxedOk
209 combine _ _ = OkToSpec
211 instance Outputable FloatingBind where
212 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
213 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
215 deFloatTop :: Floats -> [CoreBind]
216 -- For top level only; we don't expect any FloatCases
217 deFloatTop (Floats _ floats)
218 = foldrOL get [] floats
220 get (FloatLet b) bs = b:bs
221 get b bs = pprPanic "corePrepPgm" (ppr b)
223 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
224 allLazy top_lvl is_rec (Floats ok_to_spec _)
228 IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
230 -- ---------------------------------------------------------------------------
232 -- ---------------------------------------------------------------------------
234 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
235 corePrepTopBinds binds
236 = go emptyCorePrepEnv binds
238 go env [] = return emptyFloats
239 go env (bind : binds) = do (env', bind') <- corePrepTopBind env bind
240 binds' <- go env' binds
241 return (bind' `appendFloats` binds')
243 -- NB: we do need to float out of top-level bindings
244 -- Consider x = length [True,False]
250 -- We return a *list* of bindings, because we may start with
252 -- where x is demanded, in which case we want to finish with
255 -- And then x will actually end up case-bound
257 -- What happens to the CafInfo on the floated bindings? By
258 -- default, all the CafInfos will be set to MayHaveCafRefs,
261 -- This might be pessimistic, because eg. s1 & s2
262 -- might not refer to any CAFs and the GC will end up doing
263 -- more traversal than is necessary, but it's still better
264 -- than not floating the bindings at all, because then
265 -- the GC would have to traverse the structure in the heap
266 -- instead. Given this, we decided not to try to get
267 -- the CafInfo on the floated bindings correct, because
268 -- it looks difficult.
270 --------------------------------
271 corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
272 corePrepTopBind env (NonRec bndr rhs) = do
273 (env', bndr') <- cloneBndr env bndr
274 (floats, rhs') <- corePrepRhs TopLevel NonRecursive env (bndr, rhs)
275 return (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
277 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
279 --------------------------------
280 corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
281 -- This one is used for *local* bindings
282 corePrepBind env (NonRec bndr rhs) = do
283 rhs1 <- etaExpandRhs bndr rhs
284 (floats, rhs2) <- corePrepExprFloat env rhs1
285 (_, bndr') <- cloneBndr env bndr
286 (floats', bndr'') <- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2
287 -- We want bndr'' in the envt, because it records
288 -- the evaluated-ness of the binder
289 return (extendCorePrepEnv env bndr bndr'', floats')
291 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
293 --------------------------------
294 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
295 -> [(Id,CoreExpr)] -- Recursive bindings
296 -> UniqSM (CorePrepEnv, Floats)
297 -- Used for all recursive bindings, top level and otherwise
298 corePrepRecPairs lvl env pairs = do
299 (env', bndrs') <- cloneBndrs env (map fst pairs)
300 (floats_s, rhss') <- mapAndUnzipM (corePrepRhs lvl Recursive env') pairs
301 return (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
303 -- Flatten all the floats, and the currrent
304 -- group into a single giant Rec
305 flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
307 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
308 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
309 get b prs2 = pprPanic "corePrepRecPairs" (ppr b)
311 --------------------------------
312 corePrepRhs :: TopLevelFlag -> RecFlag
313 -> CorePrepEnv -> (Id, CoreExpr)
314 -> UniqSM (Floats, CoreExpr)
315 -- Used for top-level bindings, and local recursive bindings
316 corePrepRhs top_lvl is_rec env (bndr, rhs) = do
317 rhs' <- etaExpandRhs bndr rhs
318 floats_w_rhs <- corePrepExprFloat env rhs'
319 floatRhs top_lvl is_rec bndr floats_w_rhs
322 -- ---------------------------------------------------------------------------
323 -- Making arguments atomic (function args & constructor args)
324 -- ---------------------------------------------------------------------------
326 -- This is where we arrange that a non-trivial argument is let-bound
327 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
328 -> UniqSM (Floats, CoreArg)
329 corePrepArg env arg dem = do
330 (floats, arg') <- corePrepExprFloat env arg
331 if exprIsTrivial arg'
332 then return (floats, arg')
333 else do v <- newVar (exprType arg')
334 (floats', v') <- mkLocalNonRec v dem floats arg'
335 return (floats', Var v')
337 -- version that doesn't consider an scc annotation to be trivial.
338 exprIsTrivial (Var v) = True
339 exprIsTrivial (Type _) = True
340 exprIsTrivial (Lit lit) = True
341 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
342 exprIsTrivial (Note (SCC _) e) = False
343 exprIsTrivial (Note _ e) = exprIsTrivial e
344 exprIsTrivial (Cast e co) = exprIsTrivial e
345 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
346 exprIsTrivial other = False
348 -- ---------------------------------------------------------------------------
349 -- Dealing with expressions
350 -- ---------------------------------------------------------------------------
352 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
353 corePrepAnExpr env expr = do
354 (floats, expr) <- corePrepExprFloat env expr
358 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
362 -- e = let bs in e' (semantically, that is!)
365 -- f (g x) ===> ([v = g x], f v)
367 corePrepExprFloat env (Var v) = do
370 v2 = lookupCorePrepEnv env v1
371 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
373 corePrepExprFloat env expr@(Type _)
374 = return (emptyFloats, expr)
376 corePrepExprFloat env expr@(Lit lit)
377 = return (emptyFloats, expr)
379 corePrepExprFloat env (Let bind body) = do
380 (env', new_binds) <- corePrepBind env bind
381 (floats, new_body) <- corePrepExprFloat env' body
382 return (new_binds `appendFloats` floats, new_body)
384 corePrepExprFloat env (Note n@(SCC _) expr) = do
385 expr1 <- corePrepAnExpr env expr
386 (floats, expr2) <- deLamFloat expr1
387 return (floats, Note n expr2)
389 corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
390 | Just (TickBox {}) <- isTickBoxOp_maybe id = do
391 expr1 <- corePrepAnExpr env expr
392 (floats, expr2) <- deLamFloat expr1
393 return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
395 corePrepExprFloat env (Note other_note expr) = do
396 (floats, expr') <- corePrepExprFloat env expr
397 return (floats, Note other_note expr')
399 corePrepExprFloat env (Cast expr co) = do
400 (floats, expr') <- corePrepExprFloat env expr
401 return (floats, Cast expr' co)
403 corePrepExprFloat env expr@(Lam _ _) = do
404 (env', bndrs') <- cloneBndrs env bndrs
405 body' <- corePrepAnExpr env' body
406 return (emptyFloats, mkLams bndrs' body')
408 (bndrs,body) = collectBinders expr
410 corePrepExprFloat env (Case scrut bndr ty alts) = do
411 (floats1, scrut1) <- corePrepExprFloat env scrut
412 (floats2, scrut2) <- deLamFloat scrut1
414 bndr1 = bndr `setIdUnfolding` evaldUnfolding
415 -- Record that the case binder is evaluated in the alternatives
416 (env', bndr2) <- cloneBndr env bndr1
417 alts' <- mapM (sat_alt env') alts
418 return (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
420 sat_alt env (con, bs, rhs) = do
421 (env2, bs') <- cloneBndrs env bs
422 rhs1 <- corePrepAnExpr env2 rhs
424 return (con, bs', rhs2)
426 corePrepExprFloat env expr@(App _ _) = do
427 (app, (head,depth), ty, floats, ss) <- collect_args expr 0
428 MASSERT(null ss) -- make sure we used all the strictness info
430 -- Now deal with the function
432 Var fn_id -> maybeSaturate fn_id app depth floats ty
433 _other -> return (floats, app)
437 -- Deconstruct and rebuild the application, floating any non-atomic
438 -- arguments to the outside. We collect the type of the expression,
439 -- the head of the application, and the number of actual value arguments,
440 -- all of which are used to possibly saturate this application if it
441 -- has a constructor or primop at the head.
445 -> Int -- current app depth
446 -> UniqSM (CoreExpr, -- the rebuilt expression
447 (CoreExpr,Int), -- the head of the application,
448 -- and no. of args it was applied to
449 Type, -- type of the whole expr
450 Floats, -- any floats we pulled out
451 [Demand]) -- remaining argument demands
453 collect_args (App fun arg@(Type arg_ty)) depth = do
454 (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
455 return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
457 collect_args (App fun arg) depth = do
458 (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
460 (ss1, ss_rest) = case ss of
461 (ss1:ss_rest) -> (ss1, ss_rest)
463 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
464 splitFunTy_maybe fun_ty
466 (fs, arg') <- corePrepArg env arg (mkDemTy ss1 arg_ty)
467 return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
469 collect_args (Var v) depth = do
471 let v2 = lookupCorePrepEnv env v1
472 return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
474 stricts = case idNewStrictness v of
475 StrictSig (DmdType _ demands _)
476 | listLengthCmp demands depth /= GT -> demands
477 -- length demands <= depth
479 -- If depth < length demands, then we have too few args to
480 -- satisfy strictness info so we have to ignore all the
481 -- strictness info, e.g. + (error "urk")
482 -- Here, we can't evaluate the arg strictly, because this
483 -- partial application might be seq'd
485 collect_args (Cast fun co) depth = do
486 let (_ty1,ty2) = coercionKind co
487 (fun', hd, fun_ty, floats, ss) <- collect_args fun depth
488 return (Cast fun' co, hd, ty2, floats, ss)
490 collect_args (Note note fun) depth
491 | ignore_note note = do -- Drop these notes altogether
492 -- They aren't used by the code generator
493 (fun', hd, fun_ty, floats, ss) <- collect_args fun depth
494 return (fun', hd, fun_ty, floats, ss)
496 -- N-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 = do
500 (fun_floats, fun') <- corePrepExprFloat env fun
502 (floats, fn_id') <- mkLocalNonRec fn_id onceDem fun_floats fun'
503 return (Var fn_id', (Var fn_id', depth), ty, floats, [])
507 ignore_note (CoreNote _) = True
508 ignore_note InlineMe = True
509 ignore_note _other = False
510 -- We don't ignore SCCs, since they require some code generation
512 ------------------------------------------------------------------------------
513 -- Building the saturated syntax
514 -- ---------------------------------------------------------------------------
516 -- maybeSaturate deals with saturating primops and constructors
517 -- The type is the type of the entire application
518 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
519 maybeSaturate fn expr n_args floats ty
520 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
521 -- A gruesome special case
522 = do sat_expr <- saturate_it
524 -- OK, now ensure that the arg is evaluated.
525 -- But (sigh) take into account the lambdas we've now introduced
526 let (eta_bndrs, eta_body) = collectBinders sat_expr
527 (eta_floats, eta_body') <- eval_data2tag_arg eta_body
528 if null eta_bndrs then
529 return (floats `appendFloats` eta_floats, eta_body')
531 eta_body'' <- mkBinds eta_floats eta_body'
532 return (floats, mkLams eta_bndrs eta_body'')
534 | hasNoBinding fn = do sat_expr <- saturate_it
535 return (floats, sat_expr)
537 | otherwise = return (floats, expr)
540 fn_arity = idArity fn
541 excess_arity = fn_arity - n_args
543 saturate_it :: UniqSM CoreExpr
544 saturate_it | excess_arity == 0 = return expr
545 | otherwise = do us <- getUniquesM
546 return (etaExpand excess_arity us expr ty)
548 -- Ensure that the argument of DataToTagOp is evaluated
549 eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
550 eval_data2tag_arg app@(fun `App` arg)
551 | exprIsHNF arg -- Includes nullary constructors
552 = return (emptyFloats, app) -- The arg is evaluated
553 | otherwise -- Arg not evaluated, so evaluate it
554 = do arg_id <- newVar (exprType arg)
556 arg_id1 = setIdUnfolding arg_id evaldUnfolding
557 return (unitFloat (FloatCase arg_id1 arg False ),
558 fun `App` Var arg_id1)
560 eval_data2tag_arg (Note note app) -- Scc notes can appear
561 = do (floats, app') <- eval_data2tag_arg app
562 return (floats, Note note app')
564 eval_data2tag_arg other -- Should not happen
565 = pprPanic "eval_data2tag" (ppr other)
568 -- ---------------------------------------------------------------------------
569 -- Precipitating the floating bindings
570 -- ---------------------------------------------------------------------------
572 floatRhs :: TopLevelFlag -> RecFlag
574 -> (Floats, CoreExpr) -- Rhs: let binds in body
575 -> UniqSM (Floats, -- Floats out of this bind
576 CoreExpr) -- Final Rhs
578 floatRhs top_lvl is_rec bndr (floats, rhs)
579 | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
580 allLazy top_lvl is_rec floats -- at top level
581 = -- Why the test for allLazy?
582 -- v = f (x `divInt#` y)
583 -- we don't want to float the case, even if f has arity 2,
584 -- because floating the case would make it evaluated too early
588 -- Don't float; the RHS isn't a value
589 rhs' <- mkBinds floats rhs
590 return (emptyFloats, rhs')
592 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
593 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
594 -> Floats -> CoreExpr -- Rhs: let binds in body
595 -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
596 -- to record that it's been evaluated
598 mkLocalNonRec bndr dem floats rhs
599 | isUnLiftedType (idType bndr)
600 -- If this is an unlifted binding, we always make a case for it.
601 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
603 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
605 return (addFloat floats float, evald_bndr)
608 -- It's a strict let so we definitely float all the bindings
609 = let -- Don't make a case for a value binding,
610 -- even if it's strict. Otherwise we get
611 -- case (\x -> e) of ...!
612 float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
613 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
615 return (addFloat floats float, evald_bndr)
618 = do (floats', rhs') <- floatRhs NotTopLevel NonRecursive bndr (floats, rhs)
619 return (addFloat floats' (FloatLet (NonRec bndr rhs')),
620 if exprIsHNF rhs' then evald_bndr else bndr)
623 evald_bndr = bndr `setIdUnfolding` evaldUnfolding
624 -- Record if the binder is evaluated
627 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
628 mkBinds (Floats _ binds) body
629 | isNilOL binds = return body
630 | otherwise = do body' <- deLam body
631 -- Lambdas are not allowed as the body of a 'let'
632 return (foldrOL mk_bind body' binds)
634 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
635 mk_bind (FloatLet bind) body = Let bind body
637 etaExpandRhs bndr rhs = do
638 -- Eta expand to match the arity claimed by the binder
639 -- Remember, after CorePrep we must not change arity
641 -- Eta expansion might not have happened already,
642 -- because it is done by the simplifier only when
643 -- there at least one lambda already.
645 -- NB1:we could refrain when the RHS is trivial (which can happen
646 -- for exported things). This would reduce the amount of code
647 -- generated (a little) and make things a little words for
648 -- code compiled without -O. The case in point is data constructor
651 -- NB2: we have to be careful that the result of etaExpand doesn't
652 -- invalidate any of the assumptions that CorePrep is attempting
653 -- to establish. One possible cause is eta expanding inside of
654 -- an SCC note - we're now careful in etaExpand to make sure the
655 -- SCC is pushed inside any new lambdas that are generated.
657 -- NB3: It's important to do eta expansion, and *then* ANF-ising
658 -- f = /\a -> g (h 3) -- h has arity 2
659 -- If we ANF first we get
660 -- f = /\a -> let s = h 3 in g s
661 -- and now eta expansion gives
662 -- f = /\a -> \ y -> (let s = h 3 in g s) y
663 -- which is horrible.
664 -- Eta expanding first gives
665 -- f = /\a -> \y -> let s = h 3 in g s y
668 return (etaExpand arity us rhs (idType bndr))
670 -- For a GlobalId, take the Arity from the Id.
671 -- It was set in CoreTidy and must not change
672 -- For all others, just expand at will
673 arity | isGlobalId bndr = idArity bndr
674 | otherwise = exprArity rhs
676 -- ---------------------------------------------------------------------------
677 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
678 -- We arrange that they only show up as the RHS of a let(rec)
679 -- ---------------------------------------------------------------------------
681 deLam :: CoreExpr -> UniqSM CoreExpr
682 -- Takes an expression that may be a lambda,
683 -- and returns one that definitely isn't:
684 -- (\x.e) ==> let f = \x.e in f
686 (floats, expr) <- deLamFloat expr
690 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
691 -- Remove top level lambdas by let-bindinig
693 deLamFloat (Note n expr) = do
694 -- You can get things like
695 -- case e of { p -> coerce t (\s -> ...) }
696 (floats, expr') <- deLamFloat expr
697 return (floats, Note n expr')
699 deLamFloat (Cast e co) = do
700 (floats, e') <- deLamFloat e
701 return (floats, Cast e' co)
704 | null bndrs = return (emptyFloats, expr)
706 = case tryEta bndrs body of
707 Just no_lam_result -> return (emptyFloats, no_lam_result)
708 Nothing -> do fn <- newVar (exprType expr)
709 return (unitFloat (FloatLet (NonRec fn expr)),
712 (bndrs,body) = collectBinders expr
714 -- Why try eta reduction? Hasn't the simplifier already done eta?
715 -- But the simplifier only eta reduces if that leaves something
716 -- trivial (like f, or f Int). But for deLam it would be enough to
717 -- get to a partial application:
718 -- \xs. map f xs ==> map f
720 tryEta bndrs expr@(App _ _)
721 | ok_to_eta_reduce f &&
723 and (zipWith ok bndrs last_args) &&
724 not (any (`elemVarSet` fvs_remaining) bndrs)
725 = Just remaining_expr
727 (f, args) = collectArgs expr
728 remaining_expr = mkApps f remaining_args
729 fvs_remaining = exprFreeVars remaining_expr
730 (remaining_args, last_args) = splitAt n_remaining args
731 n_remaining = length args - length bndrs
733 ok bndr (Var arg) = bndr == arg
734 ok bndr other = False
736 -- we can't eta reduce something which must be saturated.
737 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
738 ok_to_eta_reduce _ = False --safe. ToDo: generalise
740 tryEta bndrs (Let bind@(NonRec b r) body)
741 | not (any (`elemVarSet` fvs) bndrs)
742 = case tryEta bndrs body of
743 Just e -> Just (Let bind e)
748 tryEta bndrs _ = Nothing
752 -- -----------------------------------------------------------------------------
754 -- -----------------------------------------------------------------------------
758 = RhsDemand { isStrict :: Bool, -- True => used at least once
759 isOnceDem :: Bool -- True => used at most once
762 mkDem :: Demand -> Bool -> RhsDemand
763 mkDem strict once = RhsDemand (isStrictDmd strict) once
765 mkDemTy :: Demand -> Type -> RhsDemand
766 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
769 bdrDem :: Id -> RhsDemand
770 bdrDem id = mkDem (idNewDemandInfo id)
773 -- safeDem :: RhsDemand
774 -- safeDem = RhsDemand False False -- always safe to use this
777 onceDem = RhsDemand False True -- used at most once
783 %************************************************************************
787 %************************************************************************
790 -- ---------------------------------------------------------------------------
792 -- ---------------------------------------------------------------------------
794 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
796 emptyCorePrepEnv :: CorePrepEnv
797 emptyCorePrepEnv = CPE emptyVarEnv
799 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
800 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
802 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
803 lookupCorePrepEnv (CPE env) id
804 = case lookupVarEnv env id of
808 ------------------------------------------------------------------------------
810 -- ---------------------------------------------------------------------------
812 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
813 cloneBndrs env bs = mapAccumLM cloneBndr env bs
815 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
818 = do bndr' <- setVarUnique bndr <$> getUniqueM
819 return (extendCorePrepEnv env bndr bndr', bndr')
821 | otherwise -- Top level things, which we don't want
822 -- to clone, have become GlobalIds by now
823 -- And we don't clone tyvars
827 ------------------------------------------------------------------------------
828 -- Cloning ccall Ids; each must have a unique name,
829 -- to give the code generator a handle to hang it on
830 -- ---------------------------------------------------------------------------
832 fiddleCCall :: Id -> UniqSM Id
834 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
835 | otherwise = return id
837 ------------------------------------------------------------------------------
838 -- Generating new binders
839 -- ---------------------------------------------------------------------------
841 newVar :: Type -> UniqSM Id
843 = seqType ty `seq` do
845 return (mkSysLocal FSLIT("sat") uniq ty)