2 % (c) The University of Glasgow, 1994-2006
5 Core pass to saturate constructors and PrimOps
9 corePrepPgm, corePrepExpr
12 #include "HsVersions.h"
14 import CoreUtils hiding (exprIsTrivial)
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; that is, function arguments
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] -> [TyCon] -> IO [CoreBind]
101 corePrepPgm dflags binds data_tycons = do
102 showPass dflags "CorePrep"
103 us <- mkSplitUniqSupply 's'
105 let implicit_binds = mkDataConWorkers data_tycons
106 -- NB: we must feed mkImplicitBinds through corePrep too
107 -- so that they are suitably cloned and eta-expanded
109 binds_out = initUs_ us $ do
110 floats1 <- corePrepTopBinds binds
111 floats2 <- corePrepTopBinds implicit_binds
112 return (deFloatTop (floats1 `appendFloats` floats2))
114 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
117 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
118 corePrepExpr dflags expr = do
119 showPass dflags "CorePrep"
120 us <- mkSplitUniqSupply 's'
121 let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
122 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
126 -- -----------------------------------------------------------------------------
128 -- -----------------------------------------------------------------------------
130 Create any necessary "implicit" bindings for data con workers. We
131 create the rather strange (non-recursive!) binding
133 $wC = \x y -> $wC x y
135 i.e. a curried constructor that allocates. This means that we can
136 treat the worker for a constructor like any other function in the rest
137 of the compiler. The point here is that CoreToStg will generate a
138 StgConApp for the RHS, rather than a call to the worker (which would
139 give a loop). As Lennart says: the ice is thin here, but it works.
141 Hmm. Should we create bindings for dictionary constructors? They are
142 always fully applied, and the bindings are just there to support
143 partial applications. But it's easier to let them through.
146 mkDataConWorkers :: [TyCon] -> [CoreBind]
147 mkDataConWorkers data_tycons
148 = [ NonRec id (Var id) -- The ice is thin here, but it works
149 | tycon <- data_tycons, -- CorePrep will eta-expand it
150 data_con <- tyConDataCons tycon,
151 let id = dataConWorkId data_con ]
156 -- ---------------------------------------------------------------------------
157 -- Dealing with bindings
158 -- ---------------------------------------------------------------------------
160 data FloatingBind = FloatLet CoreBind
161 | FloatCase Id CoreExpr Bool
162 -- The bool indicates "ok-for-speculation"
164 data Floats = Floats OkToSpec (OrdList FloatingBind)
166 -- Can we float these binds out of the rhs of a let? We cache this decision
167 -- to avoid having to recompute it in a non-linear way when there are
168 -- deeply nested lets.
170 = NotOkToSpec -- definitely not
172 | IfUnboxedOk -- only if floating an unboxed binding is ok
174 emptyFloats :: Floats
175 emptyFloats = Floats OkToSpec nilOL
177 addFloat :: Floats -> FloatingBind -> Floats
178 addFloat (Floats ok_to_spec floats) new_float
179 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
181 check (FloatLet _) = OkToSpec
182 check (FloatCase _ _ ok_for_spec)
183 | ok_for_spec = IfUnboxedOk
184 | otherwise = NotOkToSpec
185 -- The ok-for-speculation flag says that it's safe to
186 -- float this Case out of a let, and thereby do it more eagerly
187 -- We need the top-level flag because it's never ok to float
188 -- an unboxed binding to the top level
190 unitFloat :: FloatingBind -> Floats
191 unitFloat = addFloat emptyFloats
193 appendFloats :: Floats -> Floats -> Floats
194 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
195 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
197 concatFloats :: [Floats] -> Floats
198 concatFloats = foldr appendFloats emptyFloats
200 combine :: OkToSpec -> OkToSpec -> OkToSpec
201 combine NotOkToSpec _ = NotOkToSpec
202 combine _ NotOkToSpec = NotOkToSpec
203 combine IfUnboxedOk _ = IfUnboxedOk
204 combine _ IfUnboxedOk = IfUnboxedOk
205 combine _ _ = OkToSpec
207 instance Outputable FloatingBind where
208 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
209 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
211 deFloatTop :: Floats -> [CoreBind]
212 -- For top level only; we don't expect any FloatCases
213 deFloatTop (Floats _ floats)
214 = foldrOL get [] floats
216 get (FloatLet b) bs = b:bs
217 get b _ = pprPanic "corePrepPgm" (ppr b)
219 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
220 allLazy top_lvl is_rec (Floats ok_to_spec _)
224 IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
226 -- ---------------------------------------------------------------------------
228 -- ---------------------------------------------------------------------------
230 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
231 corePrepTopBinds binds
232 = go emptyCorePrepEnv binds
234 go _ [] = return emptyFloats
235 go env (bind : binds) = do (env', bind') <- corePrepTopBind env bind
236 binds' <- go env' binds
237 return (bind' `appendFloats` binds')
239 -- NB: we do need to float out of top-level bindings
240 -- Consider x = length [True,False]
246 -- We return a *list* of bindings, because we may start with
248 -- where x is demanded, in which case we want to finish with
251 -- And then x will actually end up case-bound
253 -- What happens to the CafInfo on the floated bindings? By
254 -- default, all the CafInfos will be set to MayHaveCafRefs,
257 -- This might be pessimistic, because eg. s1 & s2
258 -- might not refer to any CAFs and the GC will end up doing
259 -- more traversal than is necessary, but it's still better
260 -- than not floating the bindings at all, because then
261 -- the GC would have to traverse the structure in the heap
262 -- instead. Given this, we decided not to try to get
263 -- the CafInfo on the floated bindings correct, because
264 -- it looks difficult.
266 --------------------------------
267 corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
268 corePrepTopBind env (NonRec bndr rhs) = do
269 (env', bndr') <- cloneBndr env bndr
270 (floats, rhs') <- corePrepRhs TopLevel NonRecursive env (bndr, rhs)
271 return (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
273 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
275 --------------------------------
276 corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
277 -- This one is used for *local* bindings
278 corePrepBind env (NonRec bndr rhs) = do
279 rhs1 <- etaExpandRhs bndr rhs
280 (floats, rhs2) <- corePrepExprFloat env rhs1
281 (_, bndr') <- cloneBndr env bndr
282 (floats', bndr'') <- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2
283 -- We want bndr'' in the envt, because it records
284 -- the evaluated-ness of the binder
285 return (extendCorePrepEnv env bndr bndr'', floats')
287 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
289 --------------------------------
290 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
291 -> [(Id,CoreExpr)] -- Recursive bindings
292 -> UniqSM (CorePrepEnv, Floats)
293 -- Used for all recursive bindings, top level and otherwise
294 corePrepRecPairs lvl env pairs = do
295 (env', bndrs') <- cloneBndrs env (map fst pairs)
296 (floats_s, rhss') <- mapAndUnzipM (corePrepRhs lvl Recursive env') pairs
297 return (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
299 -- Flatten all the floats, and the currrent
300 -- group into a single giant Rec
301 flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
303 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
304 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
305 get b _ = pprPanic "corePrepRecPairs" (ppr b)
307 --------------------------------
308 corePrepRhs :: TopLevelFlag -> RecFlag
309 -> CorePrepEnv -> (Id, CoreExpr)
310 -> UniqSM (Floats, CoreExpr)
311 -- Used for top-level bindings, and local recursive bindings
312 corePrepRhs top_lvl is_rec env (bndr, rhs) = do
313 rhs' <- etaExpandRhs bndr rhs
314 floats_w_rhs <- corePrepExprFloat env rhs'
315 floatRhs top_lvl is_rec bndr floats_w_rhs
318 -- ---------------------------------------------------------------------------
319 -- Making arguments atomic (function args & constructor args)
320 -- ---------------------------------------------------------------------------
322 -- This is where we arrange that a non-trivial argument is let-bound
323 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
324 -> UniqSM (Floats, CoreArg)
325 corePrepArg env arg dem = do
326 (floats, arg') <- corePrepExprFloat env arg
327 if exprIsTrivial arg'
328 then return (floats, arg')
329 else do v <- newVar (exprType arg')
330 (floats', v') <- mkLocalNonRec v dem floats arg'
331 return (floats', Var v')
333 -- version that doesn't consider an scc annotation to be trivial.
334 exprIsTrivial :: CoreExpr -> Bool
335 exprIsTrivial (Var _) = True
336 exprIsTrivial (Type _) = True
337 exprIsTrivial (Lit _) = True
338 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
339 exprIsTrivial (Note (SCC _) _) = False
340 exprIsTrivial (Note _ e) = exprIsTrivial e
341 exprIsTrivial (Cast e _) = exprIsTrivial e
342 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
343 exprIsTrivial _ = False
345 -- ---------------------------------------------------------------------------
346 -- Dealing with expressions
347 -- ---------------------------------------------------------------------------
349 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
350 corePrepAnExpr env expr = do
351 (floats, expr) <- corePrepExprFloat env expr
355 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
359 -- e = let bs in e' (semantically, that is!)
362 -- f (g x) ===> ([v = g x], f v)
364 corePrepExprFloat env (Var v) = do
367 v2 = lookupCorePrepEnv env v1
368 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
370 corePrepExprFloat _env expr@(Type _)
371 = return (emptyFloats, expr)
373 corePrepExprFloat _env expr@(Lit _)
374 = return (emptyFloats, expr)
376 corePrepExprFloat env (Let bind body) = do
377 (env', new_binds) <- corePrepBind env bind
378 (floats, new_body) <- corePrepExprFloat env' body
379 return (new_binds `appendFloats` floats, new_body)
381 corePrepExprFloat env (Note n@(SCC _) expr) = do
382 expr1 <- corePrepAnExpr env expr
383 (floats, expr2) <- deLamFloat expr1
384 return (floats, Note n expr2)
386 corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
387 | Just (TickBox {}) <- isTickBoxOp_maybe id = do
388 expr1 <- corePrepAnExpr env expr
389 (floats, expr2) <- deLamFloat expr1
390 return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
392 corePrepExprFloat env (Note other_note expr) = do
393 (floats, expr') <- corePrepExprFloat env expr
394 return (floats, Note other_note expr')
396 corePrepExprFloat env (Cast expr co) = do
397 (floats, expr') <- corePrepExprFloat env expr
398 return (floats, Cast expr' co)
400 corePrepExprFloat env expr@(Lam _ _) = do
401 (env', bndrs') <- cloneBndrs env bndrs
402 body' <- corePrepAnExpr env' body
403 return (emptyFloats, mkLams bndrs' body')
405 (bndrs,body) = collectBinders expr
407 corePrepExprFloat env (Case scrut bndr ty alts) = do
408 (floats1, scrut1) <- corePrepExprFloat env scrut
409 (floats2, scrut2) <- deLamFloat scrut1
411 bndr1 = bndr `setIdUnfolding` evaldUnfolding
412 -- Record that the case binder is evaluated in the alternatives
413 (env', bndr2) <- cloneBndr env bndr1
414 alts' <- mapM (sat_alt env') alts
415 return (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
417 sat_alt env (con, bs, rhs) = do
418 (env2, bs') <- cloneBndrs env bs
419 rhs1 <- corePrepAnExpr env2 rhs
421 return (con, bs', rhs2)
423 corePrepExprFloat env expr@(App _ _) = do
424 (app, (head,depth), ty, floats, ss) <- collect_args expr 0
425 MASSERT(null ss) -- make sure we used all the strictness info
427 -- Now deal with the function
429 Var fn_id -> maybeSaturate fn_id app depth floats ty
430 _other -> return (floats, app)
434 -- Deconstruct and rebuild the application, floating any non-atomic
435 -- arguments to the outside. We collect the type of the expression,
436 -- the head of the application, and the number of actual value arguments,
437 -- all of which are used to possibly saturate this application if it
438 -- has a constructor or primop at the head.
442 -> Int -- current app depth
443 -> UniqSM (CoreExpr, -- the rebuilt expression
444 (CoreExpr,Int), -- the head of the application,
445 -- and no. of args it was applied to
446 Type, -- type of the whole expr
447 Floats, -- any floats we pulled out
448 [Demand]) -- remaining argument demands
450 collect_args (App fun arg@(Type arg_ty)) depth = do
451 (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
452 return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
454 collect_args (App fun arg) depth = do
455 (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
457 (ss1, ss_rest) = case ss of
458 (ss1:ss_rest) -> (ss1, ss_rest)
460 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
461 splitFunTy_maybe fun_ty
463 (fs, arg') <- corePrepArg env arg (mkDemTy ss1 arg_ty)
464 return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
466 collect_args (Var v) depth = do
468 let v2 = lookupCorePrepEnv env v1
469 return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
471 stricts = case idNewStrictness v of
472 StrictSig (DmdType _ demands _)
473 | listLengthCmp demands depth /= GT -> demands
474 -- length demands <= depth
476 -- If depth < length demands, then we have too few args to
477 -- satisfy strictness info so we have to ignore all the
478 -- strictness info, e.g. + (error "urk")
479 -- Here, we can't evaluate the arg strictly, because this
480 -- partial application might be seq'd
482 collect_args (Cast fun co) depth = do
483 let (_ty1,ty2) = coercionKind co
484 (fun', hd, _, floats, ss) <- collect_args fun depth
485 return (Cast fun' co, hd, ty2, floats, ss)
487 collect_args (Note note fun) depth
488 | ignore_note note = do -- Drop these notes altogether
489 -- They aren't used by the code generator
490 (fun', hd, fun_ty, floats, ss) <- collect_args fun depth
491 return (fun', hd, fun_ty, floats, ss)
493 -- N-variable fun, better let-bind it
494 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
495 -- since it is sure to be evaluated.
496 collect_args fun depth = do
497 (fun_floats, fun') <- corePrepExprFloat env fun
499 (floats, fn_id') <- mkLocalNonRec fn_id onceDem fun_floats fun'
500 return (Var fn_id', (Var fn_id', depth), ty, floats, [])
504 ignore_note (CoreNote _) = True
505 ignore_note InlineMe = True
506 ignore_note _other = False
507 -- We don't ignore SCCs, since they require some code generation
509 ------------------------------------------------------------------------------
510 -- Building the saturated syntax
511 -- ---------------------------------------------------------------------------
513 -- maybeSaturate deals with saturating primops and constructors
514 -- The type is the type of the entire application
515 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
516 maybeSaturate fn expr n_args floats ty
517 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
518 -- A gruesome special case
519 = do sat_expr <- saturate_it
521 -- OK, now ensure that the arg is evaluated.
522 -- But (sigh) take into account the lambdas we've now introduced
523 let (eta_bndrs, eta_body) = collectBinders sat_expr
524 (eta_floats, eta_body') <- eval_data2tag_arg eta_body
525 if null eta_bndrs then
526 return (floats `appendFloats` eta_floats, eta_body')
528 eta_body'' <- mkBinds eta_floats eta_body'
529 return (floats, mkLams eta_bndrs eta_body'')
531 | hasNoBinding fn = do sat_expr <- saturate_it
532 return (floats, sat_expr)
534 | otherwise = return (floats, expr)
537 fn_arity = idArity fn
538 excess_arity = fn_arity - n_args
540 saturate_it :: UniqSM CoreExpr
541 saturate_it | excess_arity == 0 = return expr
542 | otherwise = do us <- getUniquesM
543 return (etaExpand excess_arity us expr ty)
545 -- Ensure that the argument of DataToTagOp is evaluated
546 eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
547 eval_data2tag_arg app@(fun `App` arg)
548 | exprIsHNF arg -- Includes nullary constructors
549 = return (emptyFloats, app) -- The arg is evaluated
550 | otherwise -- Arg not evaluated, so evaluate it
551 = do arg_id <- newVar (exprType arg)
553 arg_id1 = setIdUnfolding arg_id evaldUnfolding
554 return (unitFloat (FloatCase arg_id1 arg False ),
555 fun `App` Var arg_id1)
557 eval_data2tag_arg (Note note app) -- Scc notes can appear
558 = do (floats, app') <- eval_data2tag_arg app
559 return (floats, Note note app')
561 eval_data2tag_arg other -- Should not happen
562 = pprPanic "eval_data2tag" (ppr other)
565 -- ---------------------------------------------------------------------------
566 -- Precipitating the floating bindings
567 -- ---------------------------------------------------------------------------
569 floatRhs :: TopLevelFlag -> RecFlag
571 -> (Floats, CoreExpr) -- Rhs: let binds in body
572 -> UniqSM (Floats, -- Floats out of this bind
573 CoreExpr) -- Final Rhs
575 floatRhs top_lvl is_rec _bndr (floats, rhs)
576 | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
577 allLazy top_lvl is_rec floats -- at top level
578 = -- Why the test for allLazy?
579 -- v = f (x `divInt#` y)
580 -- we don't want to float the case, even if f has arity 2,
581 -- because floating the case would make it evaluated too early
585 -- Don't float; the RHS isn't a value
586 rhs' <- mkBinds floats rhs
587 return (emptyFloats, rhs')
589 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
590 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
591 -> Floats -> CoreExpr -- Rhs: let binds in body
592 -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
593 -- to record that it's been evaluated
595 mkLocalNonRec bndr dem floats rhs
596 | isUnLiftedType (idType bndr)
597 -- If this is an unlifted binding, we always make a case for it.
598 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
600 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
602 return (addFloat floats float, evald_bndr)
605 -- It's a strict let so we definitely float all the bindings
606 = let -- Don't make a case for a value binding,
607 -- even if it's strict. Otherwise we get
608 -- case (\x -> e) of ...!
609 float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
610 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
612 return (addFloat floats float, evald_bndr)
615 = do (floats', rhs') <- floatRhs NotTopLevel NonRecursive bndr (floats, rhs)
616 return (addFloat floats' (FloatLet (NonRec bndr rhs')),
617 if exprIsHNF rhs' then evald_bndr else bndr)
620 evald_bndr = bndr `setIdUnfolding` evaldUnfolding
621 -- Record if the binder is evaluated
624 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
625 mkBinds (Floats _ binds) body
626 | isNilOL binds = return body
627 | otherwise = do body' <- deLam body
628 -- Lambdas are not allowed as the body of a 'let'
629 return (foldrOL mk_bind body' binds)
631 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
632 mk_bind (FloatLet bind) body = Let bind body
634 etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr
635 etaExpandRhs bndr rhs = do
636 -- Eta expand to match the arity claimed by the binder
637 -- Remember, CorePrep must not change arity
639 -- Eta expansion might not have happened already,
640 -- because it is done by the simplifier only when
641 -- there at least one lambda already.
643 -- NB1:we could refrain when the RHS is trivial (which can happen
644 -- for exported things). This would reduce the amount of code
645 -- generated (a little) and make things a little words for
646 -- code compiled without -O. The case in point is data constructor
649 -- NB2: we have to be careful that the result of etaExpand doesn't
650 -- invalidate any of the assumptions that CorePrep is attempting
651 -- to establish. One possible cause is eta expanding inside of
652 -- an SCC note - we're now careful in etaExpand to make sure the
653 -- SCC is pushed inside any new lambdas that are generated.
655 -- NB3: It's important to do eta expansion, and *then* ANF-ising
656 -- f = /\a -> g (h 3) -- h has arity 2
657 -- If we ANF first we get
658 -- f = /\a -> let s = h 3 in g s
659 -- and now eta expansion gives
660 -- f = /\a -> \ y -> (let s = h 3 in g s) y
661 -- which is horrible.
662 -- Eta expanding first gives
663 -- f = /\a -> \y -> let s = h 3 in g s y
666 let eta_rhs = etaExpand arity us rhs (idType bndr)
668 ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs))
669 $$ ppr rhs $$ ppr eta_rhs )
670 -- Assertion checks that eta expansion was successful
673 -- For a GlobalId, take the Arity from the Id.
674 -- It was set in CoreTidy and must not change
675 -- For all others, just expand at will
676 arity | isGlobalId bndr = idArity bndr
677 | otherwise = exprArity rhs
679 -- ---------------------------------------------------------------------------
680 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
681 -- We arrange that they only show up as the RHS of a let(rec)
682 -- ---------------------------------------------------------------------------
684 deLam :: CoreExpr -> UniqSM CoreExpr
685 -- Takes an expression that may be a lambda,
686 -- and returns one that definitely isn't:
687 -- (\x.e) ==> let f = \x.e in f
689 (floats, expr) <- deLamFloat expr
693 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
694 -- Remove top level lambdas by let-bindinig
696 deLamFloat (Note n expr) = do
697 -- You can get things like
698 -- case e of { p -> coerce t (\s -> ...) }
699 (floats, expr') <- deLamFloat expr
700 return (floats, Note n expr')
702 deLamFloat (Cast e co) = do
703 (floats, e') <- deLamFloat e
704 return (floats, Cast e' co)
707 | null bndrs = return (emptyFloats, expr)
709 = case tryEta bndrs body of
710 Just no_lam_result -> return (emptyFloats, no_lam_result)
711 Nothing -> do fn <- newVar (exprType expr)
712 return (unitFloat (FloatLet (NonRec fn expr)),
715 (bndrs,body) = collectBinders expr
717 -- Why try eta reduction? Hasn't the simplifier already done eta?
718 -- But the simplifier only eta reduces if that leaves something
719 -- trivial (like f, or f Int). But for deLam it would be enough to
720 -- get to a partial application:
721 -- \xs. map f xs ==> map f
723 tryEta :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
724 tryEta bndrs expr@(App _ _)
725 | ok_to_eta_reduce f &&
727 and (zipWith ok bndrs last_args) &&
728 not (any (`elemVarSet` fvs_remaining) bndrs)
729 = Just remaining_expr
731 (f, args) = collectArgs expr
732 remaining_expr = mkApps f remaining_args
733 fvs_remaining = exprFreeVars remaining_expr
734 (remaining_args, last_args) = splitAt n_remaining args
735 n_remaining = length args - length bndrs
737 ok bndr (Var arg) = bndr == arg
740 -- we can't eta reduce something which must be saturated.
741 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
742 ok_to_eta_reduce _ = False --safe. ToDo: generalise
744 tryEta bndrs (Let bind@(NonRec _ r) body)
745 | not (any (`elemVarSet` fvs) bndrs)
746 = case tryEta bndrs body of
747 Just e -> Just (Let bind e)
756 -- -----------------------------------------------------------------------------
758 -- -----------------------------------------------------------------------------
762 = RhsDemand { isStrict :: Bool, -- True => used at least once
763 _isOnceDem :: Bool -- True => used at most once
766 mkDem :: Demand -> Bool -> RhsDemand
767 mkDem strict once = RhsDemand (isStrictDmd strict) once
769 mkDemTy :: Demand -> Type -> RhsDemand
770 mkDemTy strict _ty = RhsDemand (isStrictDmd strict)
773 bdrDem :: Id -> RhsDemand
774 bdrDem id = mkDem (idNewDemandInfo id)
777 -- safeDem :: RhsDemand
778 -- safeDem = RhsDemand False False -- always safe to use this
781 onceDem = RhsDemand False True -- used at most once
787 %************************************************************************
791 %************************************************************************
794 -- ---------------------------------------------------------------------------
796 -- ---------------------------------------------------------------------------
798 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
800 emptyCorePrepEnv :: CorePrepEnv
801 emptyCorePrepEnv = CPE emptyVarEnv
803 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
804 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
806 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
807 lookupCorePrepEnv (CPE env) id
808 = case lookupVarEnv env id of
812 ------------------------------------------------------------------------------
814 -- ---------------------------------------------------------------------------
816 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
817 cloneBndrs env bs = mapAccumLM cloneBndr env bs
819 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
822 = do bndr' <- setVarUnique bndr <$> getUniqueM
823 return (extendCorePrepEnv env bndr bndr', bndr')
825 | otherwise -- Top level things, which we don't want
826 -- to clone, have become GlobalIds by now
827 -- And we don't clone tyvars
831 ------------------------------------------------------------------------------
832 -- Cloning ccall Ids; each must have a unique name,
833 -- to give the code generator a handle to hang it on
834 -- ---------------------------------------------------------------------------
836 fiddleCCall :: Id -> UniqSM Id
838 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
839 | otherwise = return id
841 ------------------------------------------------------------------------------
842 -- Generating new binders
843 -- ---------------------------------------------------------------------------
845 newVar :: Type -> UniqSM Id
847 = seqType ty `seq` do
849 return (mkSysLocal (fsLit "sat") uniq ty)