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)
40 -- ---------------------------------------------------------------------------
42 -- ---------------------------------------------------------------------------
44 The goal of this pass is to prepare for code generation.
46 1. Saturate constructor and primop applications.
48 2. Convert to A-normal form; that is, function arguments
51 * Use case for strict arguments:
52 f E ==> case E of x -> f x
55 * Use let for non-trivial lazy arguments
56 f E ==> let x = E in f x
57 (were f is lazy and x is non-trivial)
59 3. Similarly, convert any unboxed lets into cases.
60 [I'm experimenting with leaving 'ok-for-speculation'
61 rhss in let-form right up to this point.]
63 4. Ensure that lambdas only occur as the RHS of a binding
64 (The code generator can't deal with anything else.)
66 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
68 6. Clone all local Ids.
69 This means that all such Ids are unique, rather than the
70 weaker guarantee of no clashes which the simplifier provides.
71 And that is what the code generator needs.
73 We don't clone TyVars. The code gen doesn't need that,
74 and doing so would be tiresome because then we'd need
75 to substitute in types.
78 7. Give each dynamic CCall occurrence a fresh unique; this is
79 rather like the cloning step above.
81 8. Inject bindings for the "implicit" Ids:
82 * Constructor wrappers
85 We want curried definitions for all of these in case they
86 aren't inlined by some caller.
88 This is all done modulo type applications and abstractions, so that
89 when type erasure is done for conversion to STG, we don't end up with
90 any trivial or useless bindings.
94 -- -----------------------------------------------------------------------------
96 -- -----------------------------------------------------------------------------
99 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
100 corePrepPgm dflags binds data_tycons = do
101 showPass dflags "CorePrep"
102 us <- mkSplitUniqSupply 's'
104 let implicit_binds = mkDataConWorkers data_tycons
105 -- NB: we must feed mkImplicitBinds through corePrep too
106 -- so that they are suitably cloned and eta-expanded
108 binds_out = initUs_ us $ do
109 floats1 <- corePrepTopBinds binds
110 floats2 <- corePrepTopBinds implicit_binds
111 return (deFloatTop (floats1 `appendFloats` floats2))
113 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
116 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
117 corePrepExpr dflags expr = do
118 showPass dflags "CorePrep"
119 us <- mkSplitUniqSupply 's'
120 let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
121 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
125 -- -----------------------------------------------------------------------------
127 -- -----------------------------------------------------------------------------
129 Create any necessary "implicit" bindings for data con workers. We
130 create the rather strange (non-recursive!) binding
132 $wC = \x y -> $wC x y
134 i.e. a curried constructor that allocates. This means that we can
135 treat the worker for a constructor like any other function in the rest
136 of the compiler. The point here is that CoreToStg will generate a
137 StgConApp for the RHS, rather than a call to the worker (which would
138 give a loop). As Lennart says: the ice is thin here, but it works.
140 Hmm. Should we create bindings for dictionary constructors? They are
141 always fully applied, and the bindings are just there to support
142 partial applications. But it's easier to let them through.
145 mkDataConWorkers :: [TyCon] -> [CoreBind]
146 mkDataConWorkers data_tycons
147 = [ NonRec id (Var id) -- The ice is thin here, but it works
148 | tycon <- data_tycons, -- CorePrep will eta-expand it
149 data_con <- tyConDataCons tycon,
150 let id = dataConWorkId data_con ]
155 -- ---------------------------------------------------------------------------
156 -- Dealing with bindings
157 -- ---------------------------------------------------------------------------
159 data FloatingBind = FloatLet CoreBind
160 | FloatCase Id CoreExpr Bool
161 -- The bool indicates "ok-for-speculation"
163 data Floats = Floats OkToSpec (OrdList FloatingBind)
165 -- Can we float these binds out of the rhs of a let? We cache this decision
166 -- to avoid having to recompute it in a non-linear way when there are
167 -- deeply nested lets.
169 = NotOkToSpec -- definitely not
171 | IfUnboxedOk -- only if floating an unboxed binding is ok
173 emptyFloats :: Floats
174 emptyFloats = Floats OkToSpec nilOL
176 addFloat :: Floats -> FloatingBind -> Floats
177 addFloat (Floats ok_to_spec floats) new_float
178 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
180 check (FloatLet _) = OkToSpec
181 check (FloatCase _ _ ok_for_spec)
182 | ok_for_spec = IfUnboxedOk
183 | otherwise = NotOkToSpec
184 -- The ok-for-speculation flag says that it's safe to
185 -- float this Case out of a let, and thereby do it more eagerly
186 -- We need the top-level flag because it's never ok to float
187 -- an unboxed binding to the top level
189 unitFloat :: FloatingBind -> Floats
190 unitFloat = addFloat emptyFloats
192 appendFloats :: Floats -> Floats -> Floats
193 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
194 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
196 concatFloats :: [Floats] -> Floats
197 concatFloats = foldr appendFloats emptyFloats
199 combine :: OkToSpec -> OkToSpec -> OkToSpec
200 combine NotOkToSpec _ = NotOkToSpec
201 combine _ NotOkToSpec = NotOkToSpec
202 combine IfUnboxedOk _ = IfUnboxedOk
203 combine _ IfUnboxedOk = IfUnboxedOk
204 combine _ _ = OkToSpec
206 instance Outputable FloatingBind where
207 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
208 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
210 deFloatTop :: Floats -> [CoreBind]
211 -- For top level only; we don't expect any FloatCases
212 deFloatTop (Floats _ floats)
213 = foldrOL get [] floats
215 get (FloatLet b) bs = b:bs
216 get b _ = pprPanic "corePrepPgm" (ppr b)
218 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
219 allLazy top_lvl is_rec (Floats ok_to_spec _)
223 IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
225 -- ---------------------------------------------------------------------------
227 -- ---------------------------------------------------------------------------
229 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
230 corePrepTopBinds binds
231 = go emptyCorePrepEnv binds
233 go _ [] = return emptyFloats
234 go env (bind : binds) = do (env', bind') <- corePrepTopBind env bind
235 binds' <- go env' binds
236 return (bind' `appendFloats` binds')
238 -- NB: we do need to float out of top-level bindings
239 -- Consider x = length [True,False]
245 -- We return a *list* of bindings, because we may start with
247 -- where x is demanded, in which case we want to finish with
250 -- And then x will actually end up case-bound
252 -- What happens to the CafInfo on the floated bindings? By
253 -- default, all the CafInfos will be set to MayHaveCafRefs,
256 -- This might be pessimistic, because eg. s1 & s2
257 -- might not refer to any CAFs and the GC will end up doing
258 -- more traversal than is necessary, but it's still better
259 -- than not floating the bindings at all, because then
260 -- the GC would have to traverse the structure in the heap
261 -- instead. Given this, we decided not to try to get
262 -- the CafInfo on the floated bindings correct, because
263 -- it looks difficult.
265 --------------------------------
266 corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
267 corePrepTopBind env (NonRec bndr rhs) = do
268 (env', bndr') <- cloneBndr env bndr
269 (floats, rhs') <- corePrepRhs TopLevel NonRecursive env (bndr, rhs)
270 return (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
272 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
274 --------------------------------
275 corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
276 -- This one is used for *local* bindings
277 corePrepBind env (NonRec bndr rhs) = do
278 rhs1 <- etaExpandRhs bndr rhs
279 (floats, rhs2) <- corePrepExprFloat env rhs1
280 (_, bndr') <- cloneBndr env bndr
281 (floats', bndr'') <- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2
282 -- We want bndr'' in the envt, because it records
283 -- the evaluated-ness of the binder
284 return (extendCorePrepEnv env bndr bndr'', floats')
286 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
288 --------------------------------
289 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
290 -> [(Id,CoreExpr)] -- Recursive bindings
291 -> UniqSM (CorePrepEnv, Floats)
292 -- Used for all recursive bindings, top level and otherwise
293 corePrepRecPairs lvl env pairs = do
294 (env', bndrs') <- cloneBndrs env (map fst pairs)
295 (floats_s, rhss') <- mapAndUnzipM (corePrepRhs lvl Recursive env') pairs
296 return (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
298 -- Flatten all the floats, and the currrent
299 -- group into a single giant Rec
300 flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
302 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
303 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
304 get b _ = pprPanic "corePrepRecPairs" (ppr b)
306 --------------------------------
307 corePrepRhs :: TopLevelFlag -> RecFlag
308 -> CorePrepEnv -> (Id, CoreExpr)
309 -> UniqSM (Floats, CoreExpr)
310 -- Used for top-level bindings, and local recursive bindings
311 corePrepRhs top_lvl is_rec env (bndr, rhs) = do
312 rhs' <- etaExpandRhs bndr rhs
313 floats_w_rhs <- corePrepExprFloat env rhs'
314 floatRhs top_lvl is_rec bndr floats_w_rhs
317 -- ---------------------------------------------------------------------------
318 -- Making arguments atomic (function args & constructor args)
319 -- ---------------------------------------------------------------------------
321 -- This is where we arrange that a non-trivial argument is let-bound
322 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
323 -> UniqSM (Floats, CoreArg)
324 corePrepArg env arg dem = do
325 (floats, arg') <- corePrepExprFloat env arg
326 if exprIsTrivial arg'
327 then return (floats, arg')
328 else do v <- newVar (exprType arg')
329 (floats', v') <- mkLocalNonRec v dem floats arg'
330 return (floats', Var v')
332 -- version that doesn't consider an scc annotation to be trivial.
333 exprIsTrivial :: CoreExpr -> Bool
334 exprIsTrivial (Var _) = True
335 exprIsTrivial (Type _) = True
336 exprIsTrivial (Lit _) = True
337 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
338 exprIsTrivial (Note (SCC _) _) = False
339 exprIsTrivial (Note _ e) = exprIsTrivial e
340 exprIsTrivial (Cast e _) = exprIsTrivial e
341 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
342 exprIsTrivial _ = False
344 -- ---------------------------------------------------------------------------
345 -- Dealing with expressions
346 -- ---------------------------------------------------------------------------
348 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
349 corePrepAnExpr env expr = do
350 (floats, expr) <- corePrepExprFloat env expr
354 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
358 -- e = let bs in e' (semantically, that is!)
361 -- f (g x) ===> ([v = g x], f v)
363 corePrepExprFloat env (Var v) = do
366 v2 = lookupCorePrepEnv env v1
367 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
369 corePrepExprFloat _env expr@(Type _)
370 = return (emptyFloats, expr)
372 corePrepExprFloat _env expr@(Lit _)
373 = return (emptyFloats, expr)
375 corePrepExprFloat env (Let bind body) = do
376 (env', new_binds) <- corePrepBind env bind
377 (floats, new_body) <- corePrepExprFloat env' body
378 return (new_binds `appendFloats` floats, new_body)
380 corePrepExprFloat env (Note n@(SCC _) expr) = do
381 expr1 <- corePrepAnExpr env expr
382 (floats, expr2) <- deLamFloat expr1
383 return (floats, Note n expr2)
385 corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
386 | Just (TickBox {}) <- isTickBoxOp_maybe id = do
387 expr1 <- corePrepAnExpr env expr
388 (floats, expr2) <- deLamFloat expr1
389 return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
391 corePrepExprFloat env (Note other_note expr) = do
392 (floats, expr') <- corePrepExprFloat env expr
393 return (floats, Note other_note expr')
395 corePrepExprFloat env (Cast expr co) = do
396 (floats, expr') <- corePrepExprFloat env expr
397 return (floats, Cast expr' co)
399 corePrepExprFloat env expr@(Lam _ _) = do
400 (env', bndrs') <- cloneBndrs env bndrs
401 body' <- corePrepAnExpr env' body
402 return (emptyFloats, mkLams bndrs' body')
404 (bndrs,body) = collectBinders expr
406 corePrepExprFloat env (Case scrut bndr ty alts) = do
407 (floats1, scrut1) <- corePrepExprFloat env scrut
408 (floats2, scrut2) <- deLamFloat scrut1
410 bndr1 = bndr `setIdUnfolding` evaldUnfolding
411 -- Record that the case binder is evaluated in the alternatives
412 (env', bndr2) <- cloneBndr env bndr1
413 alts' <- mapM (sat_alt env') alts
414 return (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
416 sat_alt env (con, bs, rhs) = do
417 (env2, bs') <- cloneBndrs env bs
418 rhs1 <- corePrepAnExpr env2 rhs
420 return (con, bs', rhs2)
422 corePrepExprFloat env expr@(App _ _) = do
423 (app, (head,depth), ty, floats, ss) <- collect_args expr 0
424 MASSERT(null ss) -- make sure we used all the strictness info
426 -- Now deal with the function
428 Var fn_id -> maybeSaturate fn_id app depth floats ty
429 _other -> return (floats, app)
433 -- Deconstruct and rebuild the application, floating any non-atomic
434 -- arguments to the outside. We collect the type of the expression,
435 -- the head of the application, and the number of actual value arguments,
436 -- all of which are used to possibly saturate this application if it
437 -- has a constructor or primop at the head.
441 -> Int -- current app depth
442 -> UniqSM (CoreExpr, -- the rebuilt expression
443 (CoreExpr,Int), -- the head of the application,
444 -- and no. of args it was applied to
445 Type, -- type of the whole expr
446 Floats, -- any floats we pulled out
447 [Demand]) -- remaining argument demands
449 collect_args (App fun arg@(Type arg_ty)) depth = do
450 (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
451 return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
453 collect_args (App fun arg) depth = do
454 (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
456 (ss1, ss_rest) = case ss of
457 (ss1:ss_rest) -> (ss1, ss_rest)
459 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
460 splitFunTy_maybe fun_ty
462 (fs, arg') <- corePrepArg env arg (mkDemTy ss1 arg_ty)
463 return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
465 collect_args (Var v) depth = do
467 let v2 = lookupCorePrepEnv env v1
468 return (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 = do
482 let (_ty1,ty2) = coercionKind co
483 (fun', hd, _, floats, ss) <- collect_args fun depth
484 return (Cast fun' co, hd, ty2, floats, ss)
486 collect_args (Note note fun) depth
487 | ignore_note note = do -- Drop these notes altogether
488 -- They aren't used by the code generator
489 (fun', hd, fun_ty, floats, ss) <- collect_args fun depth
490 return (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 = do
496 (fun_floats, fun') <- corePrepExprFloat env fun
498 (floats, fn_id') <- mkLocalNonRec fn_id onceDem fun_floats fun'
499 return (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 = do sat_expr <- saturate_it
520 -- OK, now ensure that the arg is evaluated.
521 -- But (sigh) take into account the lambdas we've now introduced
522 let (eta_bndrs, eta_body) = collectBinders sat_expr
523 (eta_floats, eta_body') <- eval_data2tag_arg eta_body
524 if null eta_bndrs then
525 return (floats `appendFloats` eta_floats, eta_body')
527 eta_body'' <- mkBinds eta_floats eta_body'
528 return (floats, mkLams eta_bndrs eta_body'')
530 | hasNoBinding fn = do sat_expr <- saturate_it
531 return (floats, sat_expr)
533 | otherwise = return (floats, expr)
536 fn_arity = idArity fn
537 excess_arity = fn_arity - n_args
539 saturate_it :: UniqSM CoreExpr
540 saturate_it | excess_arity == 0 = return expr
541 | otherwise = do us <- getUniquesM
542 return (etaExpand excess_arity us expr ty)
544 -- Ensure that the argument of DataToTagOp is evaluated
545 eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
546 eval_data2tag_arg app@(fun `App` arg)
547 | exprIsHNF arg -- Includes nullary constructors
548 = return (emptyFloats, app) -- The arg is evaluated
549 | otherwise -- Arg not evaluated, so evaluate it
550 = do arg_id <- newVar (exprType arg)
552 arg_id1 = setIdUnfolding arg_id evaldUnfolding
553 return (unitFloat (FloatCase arg_id1 arg False ),
554 fun `App` Var arg_id1)
556 eval_data2tag_arg (Note note app) -- Scc notes can appear
557 = do (floats, app') <- eval_data2tag_arg app
558 return (floats, Note note app')
560 eval_data2tag_arg other -- Should not happen
561 = pprPanic "eval_data2tag" (ppr other)
564 -- ---------------------------------------------------------------------------
565 -- Precipitating the floating bindings
566 -- ---------------------------------------------------------------------------
568 floatRhs :: TopLevelFlag -> RecFlag
570 -> (Floats, CoreExpr) -- Rhs: let binds in body
571 -> UniqSM (Floats, -- Floats out of this bind
572 CoreExpr) -- Final Rhs
574 floatRhs top_lvl is_rec _bndr (floats, rhs)
575 | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
576 allLazy top_lvl is_rec floats -- at top level
577 = -- Why the test for allLazy?
578 -- v = f (x `divInt#` y)
579 -- we don't want to float the case, even if f has arity 2,
580 -- because floating the case would make it evaluated too early
584 -- Don't float; the RHS isn't a value
585 rhs' <- mkBinds floats rhs
586 return (emptyFloats, rhs')
588 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
589 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
590 -> Floats -> CoreExpr -- Rhs: let binds in body
591 -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
592 -- to record that it's been evaluated
594 mkLocalNonRec bndr dem floats rhs
595 | isUnLiftedType (idType bndr)
596 -- If this is an unlifted binding, we always make a case for it.
597 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
599 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
601 return (addFloat floats float, evald_bndr)
604 -- It's a strict let so we definitely float all the bindings
605 = let -- Don't make a case for a value binding,
606 -- even if it's strict. Otherwise we get
607 -- case (\x -> e) of ...!
608 float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
609 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
611 return (addFloat floats float, evald_bndr)
614 = do (floats', rhs') <- floatRhs NotTopLevel NonRecursive bndr (floats, rhs)
615 return (addFloat floats' (FloatLet (NonRec bndr rhs')),
616 if exprIsHNF rhs' then evald_bndr else bndr)
619 evald_bndr = bndr `setIdUnfolding` evaldUnfolding
620 -- Record if the binder is evaluated
623 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
624 mkBinds (Floats _ binds) body
625 | isNilOL binds = return body
626 | otherwise = do body' <- deLam body
627 -- Lambdas are not allowed as the body of a 'let'
628 return (foldrOL mk_bind body' binds)
630 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
631 mk_bind (FloatLet bind) body = Let bind body
633 etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr
634 etaExpandRhs bndr rhs = do
635 -- Eta expand to match the arity claimed by the binder
636 -- Remember, after CorePrep we must not change arity
638 -- Eta expansion might not have happened already,
639 -- because it is done by the simplifier only when
640 -- there at least one lambda already.
642 -- NB1:we could refrain when the RHS is trivial (which can happen
643 -- for exported things). This would reduce the amount of code
644 -- generated (a little) and make things a little words for
645 -- code compiled without -O. The case in point is data constructor
648 -- NB2: we have to be careful that the result of etaExpand doesn't
649 -- invalidate any of the assumptions that CorePrep is attempting
650 -- to establish. One possible cause is eta expanding inside of
651 -- an SCC note - we're now careful in etaExpand to make sure the
652 -- SCC is pushed inside any new lambdas that are generated.
654 -- NB3: It's important to do eta expansion, and *then* ANF-ising
655 -- f = /\a -> g (h 3) -- h has arity 2
656 -- If we ANF first we get
657 -- f = /\a -> let s = h 3 in g s
658 -- and now eta expansion gives
659 -- f = /\a -> \ y -> (let s = h 3 in g s) y
660 -- which is horrible.
661 -- Eta expanding first gives
662 -- f = /\a -> \y -> let s = h 3 in g s y
665 return (etaExpand arity us rhs (idType bndr))
667 -- For a GlobalId, take the Arity from the Id.
668 -- It was set in CoreTidy and must not change
669 -- For all others, just expand at will
670 arity | isGlobalId bndr = idArity bndr
671 | otherwise = exprArity rhs
673 -- ---------------------------------------------------------------------------
674 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
675 -- We arrange that they only show up as the RHS of a let(rec)
676 -- ---------------------------------------------------------------------------
678 deLam :: CoreExpr -> UniqSM CoreExpr
679 -- Takes an expression that may be a lambda,
680 -- and returns one that definitely isn't:
681 -- (\x.e) ==> let f = \x.e in f
683 (floats, expr) <- deLamFloat expr
687 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
688 -- Remove top level lambdas by let-bindinig
690 deLamFloat (Note n expr) = do
691 -- You can get things like
692 -- case e of { p -> coerce t (\s -> ...) }
693 (floats, expr') <- deLamFloat expr
694 return (floats, Note n expr')
696 deLamFloat (Cast e co) = do
697 (floats, e') <- deLamFloat e
698 return (floats, Cast e' co)
701 | null bndrs = return (emptyFloats, expr)
703 = case tryEta bndrs body of
704 Just no_lam_result -> return (emptyFloats, no_lam_result)
705 Nothing -> do fn <- newVar (exprType expr)
706 return (unitFloat (FloatLet (NonRec fn expr)),
709 (bndrs,body) = collectBinders expr
711 -- Why try eta reduction? Hasn't the simplifier already done eta?
712 -- But the simplifier only eta reduces if that leaves something
713 -- trivial (like f, or f Int). But for deLam it would be enough to
714 -- get to a partial application:
715 -- \xs. map f xs ==> map f
717 tryEta :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
718 tryEta bndrs expr@(App _ _)
719 | ok_to_eta_reduce f &&
721 and (zipWith ok bndrs last_args) &&
722 not (any (`elemVarSet` fvs_remaining) bndrs)
723 = Just remaining_expr
725 (f, args) = collectArgs expr
726 remaining_expr = mkApps f remaining_args
727 fvs_remaining = exprFreeVars remaining_expr
728 (remaining_args, last_args) = splitAt n_remaining args
729 n_remaining = length args - length bndrs
731 ok bndr (Var arg) = bndr == arg
734 -- we can't eta reduce something which must be saturated.
735 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
736 ok_to_eta_reduce _ = False --safe. ToDo: generalise
738 tryEta bndrs (Let bind@(NonRec _ r) body)
739 | not (any (`elemVarSet` fvs) bndrs)
740 = case tryEta bndrs body of
741 Just e -> Just (Let bind e)
750 -- -----------------------------------------------------------------------------
752 -- -----------------------------------------------------------------------------
756 = RhsDemand { isStrict :: Bool, -- True => used at least once
757 _isOnceDem :: Bool -- True => used at most once
760 mkDem :: Demand -> Bool -> RhsDemand
761 mkDem strict once = RhsDemand (isStrictDmd strict) once
763 mkDemTy :: Demand -> Type -> RhsDemand
764 mkDemTy strict _ty = RhsDemand (isStrictDmd strict)
767 bdrDem :: Id -> RhsDemand
768 bdrDem id = mkDem (idNewDemandInfo id)
771 -- safeDem :: RhsDemand
772 -- safeDem = RhsDemand False False -- always safe to use this
775 onceDem = RhsDemand False True -- used at most once
781 %************************************************************************
785 %************************************************************************
788 -- ---------------------------------------------------------------------------
790 -- ---------------------------------------------------------------------------
792 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
794 emptyCorePrepEnv :: CorePrepEnv
795 emptyCorePrepEnv = CPE emptyVarEnv
797 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
798 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
800 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
801 lookupCorePrepEnv (CPE env) id
802 = case lookupVarEnv env id of
806 ------------------------------------------------------------------------------
808 -- ---------------------------------------------------------------------------
810 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
811 cloneBndrs env bs = mapAccumLM cloneBndr env bs
813 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
816 = do bndr' <- setVarUnique bndr <$> getUniqueM
817 return (extendCorePrepEnv env bndr bndr', bndr')
819 | otherwise -- Top level things, which we don't want
820 -- to clone, have become GlobalIds by now
821 -- And we don't clone tyvars
825 ------------------------------------------------------------------------------
826 -- Cloning ccall Ids; each must have a unique name,
827 -- to give the code generator a handle to hang it on
828 -- ---------------------------------------------------------------------------
830 fiddleCCall :: Id -> UniqSM Id
832 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
833 | otherwise = return id
835 ------------------------------------------------------------------------------
836 -- Generating new binders
837 -- ---------------------------------------------------------------------------
839 newVar :: Type -> UniqSM Id
841 = seqType ty `seq` do
843 return (mkSysLocal FSLIT("sat") uniq ty)