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' && allLazy NotTopLevel NonRecursive floats
328 -- Note [Floating unlifted arguments]
329 then return (floats, arg')
330 else do v <- newVar (exprType arg')
331 (floats', v') <- mkLocalNonRec v dem floats arg'
332 return (floats', Var v')
334 -- version that doesn't consider an scc annotation to be trivial.
335 exprIsTrivial :: CoreExpr -> Bool
336 exprIsTrivial (Var _) = True
337 exprIsTrivial (Type _) = True
338 exprIsTrivial (Lit _) = True
339 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
340 exprIsTrivial (Note (SCC _) _) = False
341 exprIsTrivial (Note _ e) = exprIsTrivial e
342 exprIsTrivial (Cast e _) = exprIsTrivial e
343 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
344 exprIsTrivial _ = False
347 Note [Floating unlifted arguments]
348 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
349 Consider C (let v* = expensive in v)
351 where the "*" indicates "will be demanded". Usually v will have been
352 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
355 let v* = expensive in C v
357 because that has different strictness. Hence the use of 'allLazy'.
358 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
362 -- ---------------------------------------------------------------------------
363 -- Dealing with expressions
364 -- ---------------------------------------------------------------------------
366 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
367 corePrepAnExpr env expr = do
368 (floats, expr) <- corePrepExprFloat env expr
372 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
376 -- e = let bs in e' (semantically, that is!)
379 -- f (g x) ===> ([v = g x], f v)
381 corePrepExprFloat env (Var v) = do
384 v2 = lookupCorePrepEnv env v1
385 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
387 corePrepExprFloat _env expr@(Type _)
388 = return (emptyFloats, expr)
390 corePrepExprFloat _env expr@(Lit _)
391 = return (emptyFloats, expr)
393 corePrepExprFloat env (Let bind body) = do
394 (env', new_binds) <- corePrepBind env bind
395 (floats, new_body) <- corePrepExprFloat env' body
396 return (new_binds `appendFloats` floats, new_body)
398 corePrepExprFloat env (Note n@(SCC _) expr) = do
399 expr1 <- corePrepAnExpr env expr
400 (floats, expr2) <- deLamFloat expr1
401 return (floats, Note n expr2)
403 corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
404 | Just (TickBox {}) <- isTickBoxOp_maybe id = do
405 expr1 <- corePrepAnExpr env expr
406 (floats, expr2) <- deLamFloat expr1
407 return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
409 corePrepExprFloat env (Note other_note expr) = do
410 (floats, expr') <- corePrepExprFloat env expr
411 return (floats, Note other_note expr')
413 corePrepExprFloat env (Cast expr co) = do
414 (floats, expr') <- corePrepExprFloat env expr
415 return (floats, Cast expr' co)
417 corePrepExprFloat env expr@(Lam _ _) = do
418 (env', bndrs') <- cloneBndrs env bndrs
419 body' <- corePrepAnExpr env' body
420 return (emptyFloats, mkLams bndrs' body')
422 (bndrs,body) = collectBinders expr
424 corePrepExprFloat env (Case scrut bndr ty alts) = do
425 (floats1, scrut1) <- corePrepExprFloat env scrut
426 (floats2, scrut2) <- deLamFloat scrut1
428 bndr1 = bndr `setIdUnfolding` evaldUnfolding
429 -- Record that the case binder is evaluated in the alternatives
430 (env', bndr2) <- cloneBndr env bndr1
431 alts' <- mapM (sat_alt env') alts
432 return (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
434 sat_alt env (con, bs, rhs) = do
435 (env2, bs') <- cloneBndrs env bs
436 rhs1 <- corePrepAnExpr env2 rhs
438 return (con, bs', rhs2)
440 corePrepExprFloat env expr@(App _ _) = do
441 (app, (head,depth), ty, floats, ss) <- collect_args expr 0
442 MASSERT(null ss) -- make sure we used all the strictness info
444 -- Now deal with the function
446 Var fn_id -> maybeSaturate fn_id app depth floats ty
447 _other -> return (floats, app)
451 -- Deconstruct and rebuild the application, floating any non-atomic
452 -- arguments to the outside. We collect the type of the expression,
453 -- the head of the application, and the number of actual value arguments,
454 -- all of which are used to possibly saturate this application if it
455 -- has a constructor or primop at the head.
459 -> Int -- current app depth
460 -> UniqSM (CoreExpr, -- the rebuilt expression
461 (CoreExpr,Int), -- the head of the application,
462 -- and no. of args it was applied to
463 Type, -- type of the whole expr
464 Floats, -- any floats we pulled out
465 [Demand]) -- remaining argument demands
467 collect_args (App fun arg@(Type arg_ty)) depth = do
468 (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
469 return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
471 collect_args (App fun arg) depth = do
472 (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
474 (ss1, ss_rest) = case ss of
475 (ss1:ss_rest) -> (ss1, ss_rest)
477 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
478 splitFunTy_maybe fun_ty
480 (fs, arg') <- corePrepArg env arg (mkDemTy ss1 arg_ty)
481 return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
483 collect_args (Var v) depth = do
485 let v2 = lookupCorePrepEnv env v1
486 return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
488 stricts = case idNewStrictness v of
489 StrictSig (DmdType _ demands _)
490 | listLengthCmp demands depth /= GT -> demands
491 -- length demands <= depth
493 -- If depth < length demands, then we have too few args to
494 -- satisfy strictness info so we have to ignore all the
495 -- strictness info, e.g. + (error "urk")
496 -- Here, we can't evaluate the arg strictly, because this
497 -- partial application might be seq'd
499 collect_args (Cast fun co) depth = do
500 let (_ty1,ty2) = coercionKind co
501 (fun', hd, _, floats, ss) <- collect_args fun depth
502 return (Cast fun' co, hd, ty2, floats, ss)
504 collect_args (Note note fun) depth
505 | ignore_note note = do -- Drop these notes altogether
506 -- They aren't used by the code generator
507 (fun', hd, fun_ty, floats, ss) <- collect_args fun depth
508 return (fun', hd, fun_ty, floats, ss)
510 -- N-variable fun, better let-bind it
511 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
512 -- since it is sure to be evaluated.
513 collect_args fun depth = do
514 (fun_floats, fun') <- corePrepExprFloat env fun
516 (floats, fn_id') <- mkLocalNonRec fn_id onceDem fun_floats fun'
517 return (Var fn_id', (Var fn_id', depth), ty, floats, [])
521 ignore_note (CoreNote _) = True
522 ignore_note InlineMe = True
523 ignore_note _other = False
524 -- We don't ignore SCCs, since they require some code generation
526 ------------------------------------------------------------------------------
527 -- Building the saturated syntax
528 -- ---------------------------------------------------------------------------
530 -- maybeSaturate deals with saturating primops and constructors
531 -- The type is the type of the entire application
532 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
533 maybeSaturate fn expr n_args floats ty
534 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
535 -- A gruesome special case
536 = do sat_expr <- saturate_it
538 -- OK, now ensure that the arg is evaluated.
539 -- But (sigh) take into account the lambdas we've now introduced
540 let (eta_bndrs, eta_body) = collectBinders sat_expr
541 (eta_floats, eta_body') <- eval_data2tag_arg eta_body
542 if null eta_bndrs then
543 return (floats `appendFloats` eta_floats, eta_body')
545 eta_body'' <- mkBinds eta_floats eta_body'
546 return (floats, mkLams eta_bndrs eta_body'')
548 | hasNoBinding fn = do sat_expr <- saturate_it
549 return (floats, sat_expr)
551 | otherwise = return (floats, expr)
554 fn_arity = idArity fn
555 excess_arity = fn_arity - n_args
557 saturate_it :: UniqSM CoreExpr
558 saturate_it | excess_arity == 0 = return expr
559 | otherwise = do us <- getUniquesM
560 return (etaExpand excess_arity us expr ty)
562 -- Ensure that the argument of DataToTagOp is evaluated
563 eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
564 eval_data2tag_arg app@(fun `App` arg)
565 | exprIsHNF arg -- Includes nullary constructors
566 = return (emptyFloats, app) -- The arg is evaluated
567 | otherwise -- Arg not evaluated, so evaluate it
568 = do arg_id <- newVar (exprType arg)
570 arg_id1 = setIdUnfolding arg_id evaldUnfolding
571 return (unitFloat (FloatCase arg_id1 arg False ),
572 fun `App` Var arg_id1)
574 eval_data2tag_arg (Note note app) -- Scc notes can appear
575 = do (floats, app') <- eval_data2tag_arg app
576 return (floats, Note note app')
578 eval_data2tag_arg other -- Should not happen
579 = pprPanic "eval_data2tag" (ppr other)
582 -- ---------------------------------------------------------------------------
583 -- Precipitating the floating bindings
584 -- ---------------------------------------------------------------------------
586 floatRhs :: TopLevelFlag -> RecFlag
588 -> (Floats, CoreExpr) -- Rhs: let binds in body
589 -> UniqSM (Floats, -- Floats out of this bind
590 CoreExpr) -- Final Rhs
592 floatRhs top_lvl is_rec _bndr (floats, rhs)
593 | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
594 allLazy top_lvl is_rec floats -- at top level
595 = -- Why the test for allLazy?
596 -- v = f (x `divInt#` y)
597 -- we don't want to float the case, even if f has arity 2,
598 -- because floating the case would make it evaluated too early
602 -- Don't float; the RHS isn't a value
603 rhs' <- mkBinds floats rhs
604 return (emptyFloats, rhs')
606 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
607 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
608 -> Floats -> CoreExpr -- Rhs: let binds in body
609 -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
610 -- to record that it's been evaluated
612 mkLocalNonRec bndr dem floats rhs
613 | isUnLiftedType (idType bndr)
614 -- If this is an unlifted binding, we always make a case for it.
615 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
617 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
619 return (addFloat floats float, evald_bndr)
622 -- It's a strict let so we definitely float all the bindings
623 = let -- Don't make a case for a value binding,
624 -- even if it's strict. Otherwise we get
625 -- case (\x -> e) of ...!
626 float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
627 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
629 return (addFloat floats float, evald_bndr)
632 = do (floats', rhs') <- floatRhs NotTopLevel NonRecursive bndr (floats, rhs)
633 return (addFloat floats' (FloatLet (NonRec bndr rhs')),
634 if exprIsHNF rhs' then evald_bndr else bndr)
637 evald_bndr = bndr `setIdUnfolding` evaldUnfolding
638 -- Record if the binder is evaluated
641 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
642 mkBinds (Floats _ binds) body
643 | isNilOL binds = return body
644 | otherwise = do body' <- deLam body
645 -- Lambdas are not allowed as the body of a 'let'
646 return (foldrOL mk_bind body' binds)
648 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
649 mk_bind (FloatLet bind) body = Let bind body
651 etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr
652 etaExpandRhs bndr rhs = do
653 -- Eta expand to match the arity claimed by the binder
654 -- Remember, CorePrep must not change arity
656 -- Eta expansion might not have happened already,
657 -- because it is done by the simplifier only when
658 -- there at least one lambda already.
660 -- NB1:we could refrain when the RHS is trivial (which can happen
661 -- for exported things). This would reduce the amount of code
662 -- generated (a little) and make things a little words for
663 -- code compiled without -O. The case in point is data constructor
666 -- NB2: we have to be careful that the result of etaExpand doesn't
667 -- invalidate any of the assumptions that CorePrep is attempting
668 -- to establish. One possible cause is eta expanding inside of
669 -- an SCC note - we're now careful in etaExpand to make sure the
670 -- SCC is pushed inside any new lambdas that are generated.
672 -- NB3: It's important to do eta expansion, and *then* ANF-ising
673 -- f = /\a -> g (h 3) -- h has arity 2
674 -- If we ANF first we get
675 -- f = /\a -> let s = h 3 in g s
676 -- and now eta expansion gives
677 -- f = /\a -> \ y -> (let s = h 3 in g s) y
678 -- which is horrible.
679 -- Eta expanding first gives
680 -- f = /\a -> \y -> let s = h 3 in g s y
683 let eta_rhs = etaExpand arity us rhs (idType bndr)
685 ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs))
686 $$ ppr rhs $$ ppr eta_rhs )
687 -- Assertion checks that eta expansion was successful
690 -- For a GlobalId, take the Arity from the Id.
691 -- It was set in CoreTidy and must not change
692 -- For all others, just expand at will
693 arity | isGlobalId bndr = idArity bndr
694 | otherwise = exprArity rhs
696 -- ---------------------------------------------------------------------------
697 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
698 -- We arrange that they only show up as the RHS of a let(rec)
699 -- ---------------------------------------------------------------------------
701 deLam :: CoreExpr -> UniqSM CoreExpr
702 -- Takes an expression that may be a lambda,
703 -- and returns one that definitely isn't:
704 -- (\x.e) ==> let f = \x.e in f
706 (floats, expr) <- deLamFloat expr
710 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
711 -- Remove top level lambdas by let-bindinig
713 deLamFloat (Note n expr) = do
714 -- You can get things like
715 -- case e of { p -> coerce t (\s -> ...) }
716 (floats, expr') <- deLamFloat expr
717 return (floats, Note n expr')
719 deLamFloat (Cast e co) = do
720 (floats, e') <- deLamFloat e
721 return (floats, Cast e' co)
724 | null bndrs = return (emptyFloats, expr)
726 = case tryEta bndrs body of
727 Just no_lam_result -> return (emptyFloats, no_lam_result)
728 Nothing -> do fn <- newVar (exprType expr)
729 return (unitFloat (FloatLet (NonRec fn expr)),
732 (bndrs,body) = collectBinders expr
734 -- Why try eta reduction? Hasn't the simplifier already done eta?
735 -- But the simplifier only eta reduces if that leaves something
736 -- trivial (like f, or f Int). But for deLam it would be enough to
737 -- get to a partial application:
738 -- \xs. map f xs ==> map f
740 tryEta :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
741 tryEta bndrs expr@(App _ _)
742 | ok_to_eta_reduce f &&
744 and (zipWith ok bndrs last_args) &&
745 not (any (`elemVarSet` fvs_remaining) bndrs)
746 = Just remaining_expr
748 (f, args) = collectArgs expr
749 remaining_expr = mkApps f remaining_args
750 fvs_remaining = exprFreeVars remaining_expr
751 (remaining_args, last_args) = splitAt n_remaining args
752 n_remaining = length args - length bndrs
754 ok bndr (Var arg) = bndr == arg
757 -- we can't eta reduce something which must be saturated.
758 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
759 ok_to_eta_reduce _ = False --safe. ToDo: generalise
761 tryEta bndrs (Let bind@(NonRec _ r) body)
762 | not (any (`elemVarSet` fvs) bndrs)
763 = case tryEta bndrs body of
764 Just e -> Just (Let bind e)
773 -- -----------------------------------------------------------------------------
775 -- -----------------------------------------------------------------------------
779 = RhsDemand { isStrict :: Bool, -- True => used at least once
780 _isOnceDem :: Bool -- True => used at most once
783 mkDem :: Demand -> Bool -> RhsDemand
784 mkDem strict once = RhsDemand (isStrictDmd strict) once
786 mkDemTy :: Demand -> Type -> RhsDemand
787 mkDemTy strict _ty = RhsDemand (isStrictDmd strict)
790 bdrDem :: Id -> RhsDemand
791 bdrDem id = mkDem (idNewDemandInfo id)
794 -- safeDem :: RhsDemand
795 -- safeDem = RhsDemand False False -- always safe to use this
798 onceDem = RhsDemand False True -- used at most once
804 %************************************************************************
808 %************************************************************************
811 -- ---------------------------------------------------------------------------
813 -- ---------------------------------------------------------------------------
815 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
817 emptyCorePrepEnv :: CorePrepEnv
818 emptyCorePrepEnv = CPE emptyVarEnv
820 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
821 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
823 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
824 lookupCorePrepEnv (CPE env) id
825 = case lookupVarEnv env id of
829 ------------------------------------------------------------------------------
831 -- ---------------------------------------------------------------------------
833 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
834 cloneBndrs env bs = mapAccumLM cloneBndr env bs
836 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
839 = do bndr' <- setVarUnique bndr <$> getUniqueM
840 return (extendCorePrepEnv env bndr bndr', bndr')
842 | otherwise -- Top level things, which we don't want
843 -- to clone, have become GlobalIds by now
844 -- And we don't clone tyvars
848 ------------------------------------------------------------------------------
849 -- Cloning ccall Ids; each must have a unique name,
850 -- to give the code generator a handle to hang it on
851 -- ---------------------------------------------------------------------------
853 fiddleCCall :: Id -> UniqSM Id
855 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
856 | otherwise = return id
858 ------------------------------------------------------------------------------
859 -- Generating new binders
860 -- ---------------------------------------------------------------------------
862 newVar :: Type -> UniqSM Id
864 = seqType ty `seq` do
866 return (mkSysLocal (fsLit "sat") uniq ty)