2 % (c) The University of Glasgow, 1994-2000
4 \section{Core pass to saturate constructors and PrimOps}
8 corePrepPgm, corePrepExpr
11 #include "HsVersions.h"
13 import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
14 import CoreFVs ( exprFreeVars )
15 import CoreLint ( endPass )
17 import Type ( Type, applyTy, splitFunTy_maybe,
18 isUnLiftedType, isUnboxedTupleType, seqType )
19 import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
20 import Var ( Var, Id, setVarUnique )
23 import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType,
24 isFCallId, isGlobalId, isImplicitId,
25 isLocalId, hasNoBinding, idNewStrictness,
26 idUnfolding, isDataConWorkId_maybe, isPrimOpId_maybe
28 import DataCon ( isVanillaDataCon )
29 import PrimOp ( PrimOp( DataToTagOp ) )
30 import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) )
31 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
39 import Util ( listLengthCmp )
43 -- ---------------------------------------------------------------------------
45 -- ---------------------------------------------------------------------------
47 The goal of this pass is to prepare for code generation.
49 1. Saturate constructor and primop applications.
51 2. Convert to A-normal form:
53 * Use case for strict arguments:
54 f E ==> case E of x -> f x
57 * Use let for non-trivial lazy arguments
58 f E ==> let x = E in f x
59 (were f is lazy and x is non-trivial)
61 3. Similarly, convert any unboxed lets into cases.
62 [I'm experimenting with leaving 'ok-for-speculation'
63 rhss in let-form right up to this point.]
65 4. Ensure that lambdas only occur as the RHS of a binding
66 (The code generator can't deal with anything else.)
68 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
70 6. Clone all local Ids.
71 This means that all such Ids are unique, rather than the
72 weaker guarantee of no clashes which the simplifier provides.
73 And that is what the code generator needs.
75 We don't clone TyVars. The code gen doesn't need that,
76 and doing so would be tiresome because then we'd need
77 to substitute in types.
80 7. Give each dynamic CCall occurrence a fresh unique; this is
81 rather like the cloning step above.
83 8. Inject bindings for the "implicit" Ids:
84 * Constructor wrappers
87 We want curried definitions for all of these in case they
88 aren't inlined by some caller.
90 This is all done modulo type applications and abstractions, so that
91 when type erasure is done for conversion to STG, we don't end up with
92 any trivial or useless bindings.
96 -- -----------------------------------------------------------------------------
98 -- -----------------------------------------------------------------------------
101 corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
102 corePrepPgm dflags binds types
103 = do showPass dflags "CorePrep"
104 us <- mkSplitUniqSupply 's'
106 let implicit_binds = mkImplicitBinds types
107 -- NB: we must feed mkImplicitBinds through corePrep too
108 -- so that they are suitably cloned and eta-expanded
110 binds_out = initUs_ us (
111 corePrepTopBinds binds `thenUs` \ floats1 ->
112 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
113 returnUs (deFloatTop (floats1 `appendFloats` floats2))
116 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
119 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
120 corePrepExpr dflags expr
121 = do showPass dflags "CorePrep"
122 us <- mkSplitUniqSupply 's'
123 let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
124 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
129 -- -----------------------------------------------------------------------------
131 -- -----------------------------------------------------------------------------
133 Create any necessary "implicit" bindings (data constructors etc).
135 * Constructor workers
136 * Constructor wrappers
137 * Data type record selectors
140 In the latter three cases, the Id contains the unfolding to use for
141 the binding. In the case of data con workers we create the rather
142 strange (non-recursive!) binding
144 $wC = \x y -> $wC x y
146 i.e. a curried constructor that allocates. This means that we can
147 treat the worker for a constructor like any other function in the rest
148 of the compiler. The point here is that CoreToStg will generate a
149 StgConApp for the RHS, rather than a call to the worker (which would
150 give a loop). As Lennart says: the ice is thin here, but it works.
152 Hmm. Should we create bindings for dictionary constructors? They are
153 always fully applied, and the bindings are just there to support
154 partial applications. But it's easier to let them through.
157 mkImplicitBinds type_env
158 = [ NonRec id (get_unfolding id)
159 | AnId id <- typeEnvElts type_env, isImplicitId id ]
160 -- The type environment already contains all the implicit Ids,
161 -- so we just filter them out
163 -- The etaExpand is so that the manifest arity of the
164 -- binding matches its claimed arity, which is an
165 -- invariant of top level bindings going into the code gen
167 get_unfolding id -- See notes above
168 | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works
169 -- CorePrep will eta-expand it
170 | otherwise = unfoldingTemplate (idUnfolding id)
175 -- ---------------------------------------------------------------------------
176 -- Dealing with bindings
177 -- ---------------------------------------------------------------------------
179 data FloatingBind = FloatLet CoreBind
180 | FloatCase Id CoreExpr Bool
181 -- The bool indicates "ok-for-speculation"
183 data Floats = Floats OkToSpec (OrdList FloatingBind)
185 -- Can we float these binds out of the rhs of a let? We cache this decision
186 -- to avoid having to recompute it in a non-linear way when there are
187 -- deeply nested lets.
189 = NotOkToSpec -- definitely not
191 | IfUnboxedOk -- only if floating an unboxed binding is ok
193 emptyFloats :: Floats
194 emptyFloats = Floats OkToSpec nilOL
196 addFloat :: Floats -> FloatingBind -> Floats
197 addFloat (Floats ok_to_spec floats) new_float
198 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
200 check (FloatLet _) = OkToSpec
201 check (FloatCase _ _ ok_for_spec)
202 | ok_for_spec = IfUnboxedOk
203 | otherwise = NotOkToSpec
204 -- The ok-for-speculation flag says that it's safe to
205 -- float this Case out of a let, and thereby do it more eagerly
206 -- We need the top-level flag because it's never ok to float
207 -- an unboxed binding to the top level
209 unitFloat :: FloatingBind -> Floats
210 unitFloat = addFloat emptyFloats
212 appendFloats :: Floats -> Floats -> Floats
213 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
214 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
216 concatFloats :: [Floats] -> Floats
217 concatFloats = foldr appendFloats emptyFloats
219 combine NotOkToSpec _ = NotOkToSpec
220 combine _ NotOkToSpec = NotOkToSpec
221 combine IfUnboxedOk _ = IfUnboxedOk
222 combine _ IfUnboxedOk = IfUnboxedOk
223 combine _ _ = OkToSpec
225 instance Outputable FloatingBind where
226 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
227 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
229 deFloatTop :: Floats -> [CoreBind]
230 -- For top level only; we don't expect any FloatCases
231 deFloatTop (Floats _ floats)
232 = foldrOL get [] floats
234 get (FloatLet b) bs = b:bs
235 get b bs = pprPanic "corePrepPgm" (ppr b)
237 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
238 allLazy top_lvl is_rec (Floats ok_to_spec _)
242 IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
244 -- ---------------------------------------------------------------------------
246 -- ---------------------------------------------------------------------------
248 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
249 corePrepTopBinds binds
250 = go emptyCorePrepEnv binds
252 go env [] = returnUs emptyFloats
253 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
254 go env' binds `thenUs` \ binds' ->
255 returnUs (bind' `appendFloats` binds')
257 -- NB: we do need to float out of top-level bindings
258 -- Consider x = length [True,False]
264 -- We return a *list* of bindings, because we may start with
266 -- where x is demanded, in which case we want to finish with
269 -- And then x will actually end up case-bound
271 -- What happens to the CafInfo on the floated bindings? By
272 -- default, all the CafInfos will be set to MayHaveCafRefs,
275 -- This might be pessimistic, because eg. s1 & s2
276 -- might not refer to any CAFs and the GC will end up doing
277 -- more traversal than is necessary, but it's still better
278 -- than not floating the bindings at all, because then
279 -- the GC would have to traverse the structure in the heap
280 -- instead. Given this, we decided not to try to get
281 -- the CafInfo on the floated bindings correct, because
282 -- it looks difficult.
284 --------------------------------
285 corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
286 corePrepTopBind env (NonRec bndr rhs)
287 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
288 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
289 returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
291 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
293 --------------------------------
294 corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
295 -- This one is used for *local* bindings
296 corePrepBind env (NonRec bndr rhs)
297 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
298 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
299 cloneBndr env bndr `thenUs` \ (_, bndr') ->
300 mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') ->
301 -- We want bndr'' in the envt, because it records
302 -- the evaluated-ness of the binder
303 returnUs (extendCorePrepEnv env bndr bndr'', floats')
305 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
307 --------------------------------
308 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
309 -> [(Id,CoreExpr)] -- Recursive bindings
310 -> UniqSM (CorePrepEnv, Floats)
311 -- Used for all recursive bindings, top level and otherwise
312 corePrepRecPairs lvl env pairs
313 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
314 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
315 returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
317 -- Flatten all the floats, and the currrent
318 -- group into a single giant Rec
319 flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
321 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
322 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
323 get b prs2 = pprPanic "corePrepRecPairs" (ppr b)
325 --------------------------------
326 corePrepRhs :: TopLevelFlag -> RecFlag
327 -> CorePrepEnv -> (Id, CoreExpr)
328 -> UniqSM (Floats, CoreExpr)
329 -- Used for top-level bindings, and local recursive bindings
330 corePrepRhs top_lvl is_rec env (bndr, rhs)
331 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
332 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
333 floatRhs top_lvl is_rec bndr floats_w_rhs
336 -- ---------------------------------------------------------------------------
337 -- Making arguments atomic (function args & constructor args)
338 -- ---------------------------------------------------------------------------
340 -- This is where we arrange that a non-trivial argument is let-bound
341 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
342 -> UniqSM (Floats, CoreArg)
343 corePrepArg env arg dem
344 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
345 if exprIsTrivial arg'
346 then returnUs (floats, arg')
347 else newVar (exprType arg') `thenUs` \ v ->
348 mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') ->
349 returnUs (floats', Var v')
351 -- version that doesn't consider an scc annotation to be trivial.
352 exprIsTrivial (Var v) = True
353 exprIsTrivial (Type _) = True
354 exprIsTrivial (Lit lit) = True
355 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
356 exprIsTrivial (Note (SCC _) e) = False
357 exprIsTrivial (Note _ e) = exprIsTrivial e
358 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
359 exprIsTrivial other = False
361 -- ---------------------------------------------------------------------------
362 -- Dealing with expressions
363 -- ---------------------------------------------------------------------------
365 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
366 corePrepAnExpr env expr
367 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
371 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
375 -- e = let bs in e' (semantically, that is!)
378 -- f (g x) ===> ([v = g x], f v)
380 corePrepExprFloat env (Var v)
381 = fiddleCCall v `thenUs` \ v1 ->
383 v2 = lookupCorePrepEnv env v1
385 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
387 corePrepExprFloat env expr@(Type _)
388 = returnUs (emptyFloats, expr)
390 corePrepExprFloat env expr@(Lit lit)
391 = returnUs (emptyFloats, expr)
393 corePrepExprFloat env (Let bind body)
394 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
395 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
396 returnUs (new_binds `appendFloats` floats, new_body)
398 corePrepExprFloat env (Note n@(SCC _) expr)
399 = corePrepAnExpr env expr `thenUs` \ expr1 ->
400 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
401 returnUs (floats, Note n expr2)
403 corePrepExprFloat env (Note other_note expr)
404 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
405 returnUs (floats, Note other_note expr')
407 corePrepExprFloat env expr@(Lam _ _)
408 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
409 corePrepAnExpr env' body `thenUs` \ body' ->
410 returnUs (emptyFloats, mkLams bndrs' body')
412 (bndrs,body) = collectBinders expr
414 corePrepExprFloat env (Case scrut bndr ty alts)
415 = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
416 deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
418 bndr1 = bndr `setIdUnfolding` evaldUnfolding
419 -- Record that the case binder is evaluated in the alternatives
421 cloneBndr env bndr1 `thenUs` \ (env', bndr2) ->
422 mapUs (sat_alt env') alts `thenUs` \ alts' ->
423 returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
425 sat_alt env (con, bs, rhs)
427 env1 = setGadt env con
429 cloneBndrs env1 bs `thenUs` \ (env2, bs') ->
430 corePrepAnExpr env2 rhs `thenUs` \ rhs1 ->
431 deLam rhs1 `thenUs` \ rhs2 ->
432 returnUs (con, bs', rhs2)
434 corePrepExprFloat env expr@(App _ _)
435 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
436 ASSERT(null ss) -- make sure we used all the strictness info
438 -- Now deal with the function
440 Var fn_id -> maybeSaturate fn_id app depth floats ty
441 _other -> returnUs (floats, app)
445 -- Deconstruct and rebuild the application, floating any non-atomic
446 -- arguments to the outside. We collect the type of the expression,
447 -- the head of the application, and the number of actual value arguments,
448 -- all of which are used to possibly saturate this application if it
449 -- has a constructor or primop at the head.
453 -> Int -- current app depth
454 -> UniqSM (CoreExpr, -- the rebuilt expression
455 (CoreExpr,Int), -- the head of the application,
456 -- and no. of args it was applied to
457 Type, -- type of the whole expr
458 Floats, -- any floats we pulled out
459 [Demand]) -- remaining argument demands
461 collect_args (App fun arg@(Type arg_ty)) depth
462 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
463 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
465 collect_args (App fun arg) depth
466 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
468 (ss1, ss_rest) = case ss of
469 (ss1:ss_rest) -> (ss1, ss_rest)
471 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
472 splitFunTy_maybe fun_ty
474 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
475 returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
477 collect_args (Var v) depth
478 = fiddleCCall v `thenUs` \ v1 ->
480 v2 = lookupCorePrepEnv env v1
482 returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
484 stricts = case idNewStrictness v of
485 StrictSig (DmdType _ demands _)
486 | listLengthCmp demands depth /= GT -> demands
487 -- length demands <= depth
489 -- If depth < length demands, then we have too few args to
490 -- satisfy strictness info so we have to ignore all the
491 -- strictness info, e.g. + (error "urk")
492 -- Here, we can't evaluate the arg strictly, because this
493 -- partial application might be seq'd
496 collect_args (Note (Coerce ty1 ty2) fun) depth
497 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
498 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
500 collect_args (Note note fun) depth
501 | ignore_note note -- Drop these notes altogether
502 -- They aren't used by the code generator
503 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
504 returnUs (fun', hd, fun_ty, floats, ss)
506 -- N-variable fun, better let-bind it
507 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
508 -- since it is sure to be evaluated.
509 collect_args fun depth
510 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
511 newVar ty `thenUs` \ fn_id ->
512 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') ->
513 returnUs (Var fn_id', (Var fn_id', depth), ty, floats, [])
517 ignore_note (CoreNote _) = True
518 ignore_note InlineCall = True
519 ignore_note InlineMe = True
520 ignore_note _other = False
521 -- We don't ignore SCCs, since they require some code generation
523 ------------------------------------------------------------------------------
524 -- Building the saturated syntax
525 -- ---------------------------------------------------------------------------
527 -- maybeSaturate deals with saturating primops and constructors
528 -- The type is the type of the entire application
529 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
530 maybeSaturate fn expr n_args floats ty
531 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
532 -- A gruesome special case
533 = saturate_it `thenUs` \ sat_expr ->
535 -- OK, now ensure that the arg is evaluated.
536 -- But (sigh) take into account the lambdas we've now introduced
538 (eta_bndrs, eta_body) = collectBinders sat_expr
540 eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') ->
541 if null eta_bndrs then
542 returnUs (floats `appendFloats` eta_floats, eta_body')
544 mkBinds eta_floats eta_body' `thenUs` \ eta_body'' ->
545 returnUs (floats, mkLams eta_bndrs eta_body'')
547 | hasNoBinding fn = saturate_it `thenUs` \ sat_expr ->
548 returnUs (floats, sat_expr)
550 | otherwise = returnUs (floats, expr)
553 fn_arity = idArity fn
554 excess_arity = fn_arity - n_args
556 saturate_it :: UniqSM CoreExpr
557 saturate_it | excess_arity == 0 = returnUs expr
558 | otherwise = getUniquesUs `thenUs` \ us ->
559 returnUs (etaExpand excess_arity us expr ty)
561 -- Ensure that the argument of DataToTagOp is evaluated
562 eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
563 eval_data2tag_arg app@(fun `App` arg)
564 | exprIsValue arg -- Includes nullary constructors
565 = returnUs (emptyFloats, app) -- The arg is evaluated
566 | otherwise -- Arg not evaluated, so evaluate it
567 = newVar (exprType arg) `thenUs` \ arg_id ->
569 arg_id1 = setIdUnfolding arg_id evaldUnfolding
571 returnUs (unitFloat (FloatCase arg_id1 arg False ),
572 fun `App` Var arg_id1)
574 eval_data2tag_arg (Note note app) -- Scc notes can appear
575 = eval_data2tag_arg app `thenUs` \ (floats, app') ->
576 returnUs (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 || exprIsValue 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
599 returnUs (floats, rhs)
602 -- Don't float; the RHS isn't a value
603 = mkBinds floats rhs `thenUs` \ rhs' ->
604 returnUs (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 returnUs (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 | exprIsValue rhs = FloatLet (NonRec bndr rhs)
627 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
629 returnUs (addFloat floats float, evald_bndr)
632 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
633 returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
634 if exprIsValue 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 = returnUs body
644 | otherwise = deLam body `thenUs` \ body' ->
645 -- Lambdas are not allowed as the body of a 'let'
646 returnUs (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 bndr rhs
652 = -- Eta expand to match the arity claimed by the binder
653 -- Remember, after CorePrep we must not change arity
655 -- Eta expansion might not have happened already,
656 -- because it is done by the simplifier only when
657 -- there at least one lambda already.
659 -- NB1:we could refrain when the RHS is trivial (which can happen
660 -- for exported things). This would reduce the amount of code
661 -- generated (a little) and make things a little words for
662 -- code compiled without -O. The case in point is data constructor
665 -- NB2: we have to be careful that the result of etaExpand doesn't
666 -- invalidate any of the assumptions that CorePrep is attempting
667 -- to establish. One possible cause is eta expanding inside of
668 -- an SCC note - we're now careful in etaExpand to make sure the
669 -- SCC is pushed inside any new lambdas that are generated.
671 -- NB3: It's important to do eta expansion, and *then* ANF-ising
672 -- f = /\a -> g (h 3) -- h has arity 2
673 -- If we ANF first we get
674 -- f = /\a -> let s = h 3 in g s
675 -- and now eta expansion gives
676 -- f = /\a -> \ y -> (let s = h 3 in g s) y
677 -- which is horrible.
678 -- Eta expanding first gives
679 -- f = /\a -> \y -> let s = h 3 in g s y
681 getUniquesUs `thenUs` \ us ->
682 returnUs (etaExpand arity us rhs (idType bndr))
684 -- For a GlobalId, take the Arity from the Id.
685 -- It was set in CoreTidy and must not change
686 -- For all others, just expand at will
687 arity | isGlobalId bndr = idArity bndr
688 | otherwise = exprArity rhs
690 -- ---------------------------------------------------------------------------
691 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
692 -- We arrange that they only show up as the RHS of a let(rec)
693 -- ---------------------------------------------------------------------------
695 deLam :: CoreExpr -> UniqSM CoreExpr
697 deLamFloat expr `thenUs` \ (floats, expr) ->
701 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
702 -- Remove top level lambdas by let-bindinig
704 deLamFloat (Note n expr)
705 = -- You can get things like
706 -- case e of { p -> coerce t (\s -> ...) }
707 deLamFloat expr `thenUs` \ (floats, expr') ->
708 returnUs (floats, Note n expr')
711 | null bndrs = returnUs (emptyFloats, expr)
713 = case tryEta bndrs body of
714 Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
715 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
716 returnUs (unitFloat (FloatLet (NonRec fn expr)),
719 (bndrs,body) = collectBinders expr
721 -- Why try eta reduction? Hasn't the simplifier already done eta?
722 -- But the simplifier only eta reduces if that leaves something
723 -- trivial (like f, or f Int). But for deLam it would be enough to
724 -- get to a partial application, like (map f).
726 tryEta bndrs expr@(App _ _)
727 | ok_to_eta_reduce f &&
729 and (zipWith ok bndrs last_args) &&
730 not (any (`elemVarSet` fvs_remaining) bndrs)
731 = Just remaining_expr
733 (f, args) = collectArgs expr
734 remaining_expr = mkApps f remaining_args
735 fvs_remaining = exprFreeVars remaining_expr
736 (remaining_args, last_args) = splitAt n_remaining args
737 n_remaining = length args - length bndrs
739 ok bndr (Var arg) = bndr == arg
740 ok bndr other = False
742 -- we can't eta reduce something which must be saturated.
743 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
744 ok_to_eta_reduce _ = False --safe. ToDo: generalise
746 tryEta bndrs (Let bind@(NonRec b r) body)
747 | not (any (`elemVarSet` fvs) bndrs)
748 = case tryEta bndrs body of
749 Just e -> Just (Let bind e)
754 tryEta bndrs _ = Nothing
758 -- -----------------------------------------------------------------------------
760 -- -----------------------------------------------------------------------------
764 = RhsDemand { isStrict :: Bool, -- True => used at least once
765 isOnceDem :: Bool -- True => used at most once
768 mkDem :: Demand -> Bool -> RhsDemand
769 mkDem strict once = RhsDemand (isStrictDmd strict) once
771 mkDemTy :: Demand -> Type -> RhsDemand
772 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
775 bdrDem :: Id -> RhsDemand
776 bdrDem id = mkDem (idNewDemandInfo id)
779 -- safeDem :: RhsDemand
780 -- safeDem = RhsDemand False False -- always safe to use this
783 onceDem = RhsDemand False True -- used at most once
789 %************************************************************************
793 %************************************************************************
796 -- ---------------------------------------------------------------------------
798 -- ---------------------------------------------------------------------------
800 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
801 Bool -- True <=> inside a GADT case; see Note [GADT]
805 -- Be careful with cloning inside GADTs. For example,
806 -- /\a. \f::a. \x::T a. case x of { T -> f True; ... }
807 -- The case on x may refine the type of f to be a function type.
808 -- Without this type refinement, exprType (f True) may simply fail,
811 -- Solution: remember when we are inside a potentially-type-refining case,
812 -- and in that situation use the type from the old occurrence
813 -- when looking up occurrences
815 emptyCorePrepEnv :: CorePrepEnv
816 emptyCorePrepEnv = CPE emptyVarEnv False
818 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
819 extendCorePrepEnv (CPE env gadt) id id' = CPE (extendVarEnv env id id') gadt
821 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
822 -- See Note [GADT] above
823 lookupCorePrepEnv (CPE env gadt) id
824 = case lookupVarEnv env id of
826 Just id' | gadt -> setIdType id' (idType id)
829 setGadt :: CorePrepEnv -> AltCon -> CorePrepEnv
830 setGadt env@(CPE id_env _) (DataAlt data_con) | not (isVanillaDataCon data_con) = CPE id_env True
831 setGadt env other = env
834 ------------------------------------------------------------------------------
836 -- ---------------------------------------------------------------------------
838 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
839 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
841 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
844 = getUniqueUs `thenUs` \ uniq ->
846 bndr' = setVarUnique bndr uniq
848 returnUs (extendCorePrepEnv env bndr bndr', bndr')
850 | otherwise -- Top level things, which we don't want
851 -- to clone, have become GlobalIds by now
852 -- And we don't clone tyvars
853 = returnUs (env, bndr)
856 ------------------------------------------------------------------------------
857 -- Cloning ccall Ids; each must have a unique name,
858 -- to give the code generator a handle to hang it on
859 -- ---------------------------------------------------------------------------
861 fiddleCCall :: Id -> UniqSM Id
863 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
864 returnUs (id `setVarUnique` uniq)
865 | otherwise = returnUs id
867 ------------------------------------------------------------------------------
868 -- Generating new binders
869 -- ---------------------------------------------------------------------------
871 newVar :: Type -> UniqSM Id
874 getUniqueUs `thenUs` \ uniq ->
875 returnUs (mkSysLocal FSLIT("sat") uniq ty)