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, isTyVarTy,
18 isUnLiftedType, isUnboxedTupleType, repType, seqType )
19 import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
20 import PrimOp ( PrimOp(..) )
21 import Var ( Var, Id, setVarUnique )
24 import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
25 setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
26 isLocalId, hasNoBinding, idNewStrictness,
27 isDataConId_maybe, idUnfolding
29 import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
30 import Unique ( mkBuiltinUnique )
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. Do the seq/par munging. See notes with mkCase below.
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 -> ModDetails -> IO ModDetails
102 corePrepPgm dflags mod_details
103 = do showPass dflags "CorePrep"
104 us <- mkSplitUniqSupply 's'
106 let implicit_binds = mkImplicitBinds (md_types mod_details)
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 (md_binds mod_details) `thenUs` \ floats1 ->
112 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
113 returnUs (deFloatTop (floats1 `appOL` floats2))
116 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
117 return (mod_details { md_binds = 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 emptyVarEnv 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 | id <- implicitTyThingIds (typeEnvElts type_env) ]
160 -- The etaExpand is so that the manifest arity of the
161 -- binding matches its claimed arity, which is an
162 -- invariant of top level bindings going into the code gen
164 tmpl_uniqs = map mkBuiltinUnique [1..]
166 get_unfolding id -- See notes above
167 | Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works
168 | otherwise = unfoldingTemplate (idUnfolding id)
173 -- ---------------------------------------------------------------------------
174 -- Dealing with bindings
175 -- ---------------------------------------------------------------------------
177 data FloatingBind = FloatLet CoreBind
178 | FloatCase Id CoreExpr Bool
179 -- The bool indicates "ok-for-speculation"
181 instance Outputable FloatingBind where
182 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
183 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
185 type CloneEnv = IdEnv Id -- Clone local Ids
187 deFloatTop :: OrdList FloatingBind -> [CoreBind]
188 -- For top level only; we don't expect any FloatCases
190 = foldrOL get [] floats
192 get (FloatLet b) bs = b:bs
193 get b bs = pprPanic "corePrepPgm" (ppr b)
195 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
196 allLazy top_lvl is_rec floats
197 = foldrOL check True floats
199 unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
201 check (FloatLet _) y = y
202 check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
203 -- The ok-for-speculation flag says that it's safe to
204 -- float this Case out of a let, and thereby do it more eagerly
205 -- We need the top-level flag because it's never ok to float
206 -- an unboxed binding to the top level
208 -- ---------------------------------------------------------------------------
210 -- ---------------------------------------------------------------------------
212 corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
213 corePrepTopBinds binds
214 = go emptyVarEnv binds
216 go env [] = returnUs nilOL
217 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
218 go env' binds `thenUs` \ binds' ->
219 returnUs (bind' `appOL` binds')
221 -- NB: we do need to float out of top-level bindings
222 -- Consider x = length [True,False]
228 -- We return a *list* of bindings, because we may start with
230 -- where x is demanded, in which case we want to finish with
233 -- And then x will actually end up case-bound
235 --------------------------------
236 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
237 corePrepTopBind env (NonRec bndr rhs)
238 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
239 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
240 returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
242 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
244 --------------------------------
245 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
246 -- This one is used for *local* bindings
247 corePrepBind env (NonRec bndr rhs)
248 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
249 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
250 cloneBndr env bndr `thenUs` \ (env', bndr') ->
251 mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
252 returnUs (env', floats')
254 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
256 --------------------------------
257 corePrepRecPairs :: TopLevelFlag -> CloneEnv
258 -> [(Id,CoreExpr)] -- Recursive bindings
259 -> UniqSM (CloneEnv, OrdList FloatingBind)
260 -- Used for all recursive bindings, top level and otherwise
261 corePrepRecPairs lvl env pairs
262 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
263 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
264 returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
266 -- Flatten all the floats, and the currrent
267 -- group into a single giant Rec
268 flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
270 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
271 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
273 --------------------------------
274 corePrepRhs :: TopLevelFlag -> RecFlag
275 -> CloneEnv -> (Id, CoreExpr)
276 -> UniqSM (OrdList FloatingBind, CoreExpr)
277 -- Used for top-level bindings, and local recursive bindings
278 corePrepRhs top_lvl is_rec env (bndr, rhs)
279 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
280 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
281 floatRhs top_lvl is_rec bndr floats_w_rhs
284 -- ---------------------------------------------------------------------------
285 -- Making arguments atomic (function args & constructor args)
286 -- ---------------------------------------------------------------------------
288 -- This is where we arrange that a non-trivial argument is let-bound
289 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
290 -> UniqSM (OrdList FloatingBind, CoreArg)
291 corePrepArg env arg dem
292 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
293 if exprIsTrivial arg'
294 then returnUs (floats, arg')
295 else newVar (exprType arg') `thenUs` \ v ->
296 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
297 returnUs (floats', Var v)
299 -- version that doesn't consider an scc annotation to be trivial.
300 exprIsTrivial (Var v) = True
301 exprIsTrivial (Type _) = True
302 exprIsTrivial (Lit lit) = True
303 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
304 exprIsTrivial (Note (SCC _) e) = False
305 exprIsTrivial (Note _ e) = exprIsTrivial e
306 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
307 exprIsTrivial other = False
309 -- ---------------------------------------------------------------------------
310 -- Dealing with expressions
311 -- ---------------------------------------------------------------------------
313 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
314 corePrepAnExpr env expr
315 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
319 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
323 -- e = let bs in e' (semantically, that is!)
326 -- f (g x) ===> ([v = g x], f v)
328 corePrepExprFloat env (Var v)
329 = fiddleCCall v `thenUs` \ v1 ->
330 let v2 = lookupVarEnv env v1 `orElse` v1 in
331 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
332 returnUs (nilOL, app)
334 corePrepExprFloat env expr@(Type _)
335 = returnUs (nilOL, expr)
337 corePrepExprFloat env expr@(Lit lit)
338 = returnUs (nilOL, expr)
340 corePrepExprFloat env (Let bind body)
341 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
342 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
343 returnUs (new_binds `appOL` floats, new_body)
345 corePrepExprFloat env (Note n@(SCC _) expr)
346 = corePrepAnExpr env expr `thenUs` \ expr1 ->
347 deLam expr1 `thenUs` \ expr2 ->
348 returnUs (nilOL, Note n expr2)
350 corePrepExprFloat env (Note other_note expr)
351 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
352 returnUs (floats, Note other_note expr')
354 corePrepExprFloat env expr@(Lam _ _)
355 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
356 corePrepAnExpr env' body `thenUs` \ body' ->
357 returnUs (nilOL, mkLams bndrs' body')
359 (bndrs,body) = collectBinders expr
361 corePrepExprFloat env (Case scrut bndr alts)
362 = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
363 cloneBndr env bndr `thenUs` \ (env', bndr') ->
364 mapUs (sat_alt env') alts `thenUs` \ alts' ->
365 returnUs (floats, mkCase scrut' bndr' alts')
367 sat_alt env (con, bs, rhs)
368 = cloneBndrs env bs `thenUs` \ (env', bs') ->
369 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
370 deLam rhs1 `thenUs` \ rhs2 ->
371 returnUs (con, bs', rhs2)
373 corePrepExprFloat env expr@(App _ _)
374 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
375 ASSERT(null ss) -- make sure we used all the strictness info
377 -- Now deal with the function
379 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
380 returnUs (floats, app')
382 _other -> returnUs (floats, app)
386 -- Deconstruct and rebuild the application, floating any non-atomic
387 -- arguments to the outside. We collect the type of the expression,
388 -- the head of the application, and the number of actual value arguments,
389 -- all of which are used to possibly saturate this application if it
390 -- has a constructor or primop at the head.
394 -> Int -- current app depth
395 -> UniqSM (CoreExpr, -- the rebuilt expression
396 (CoreExpr,Int), -- the head of the application,
397 -- and no. of args it was applied to
398 Type, -- type of the whole expr
399 OrdList FloatingBind, -- any floats we pulled out
400 [Demand]) -- remaining argument demands
402 collect_args (App fun arg@(Type arg_ty)) depth
403 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
404 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
406 collect_args (App fun arg) depth
407 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
409 (ss1, ss_rest) = case ss of
410 (ss1:ss_rest) -> (ss1, ss_rest)
412 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
413 splitFunTy_maybe fun_ty
415 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
416 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
418 collect_args (Var v) depth
419 = fiddleCCall v `thenUs` \ v1 ->
420 let v2 = lookupVarEnv env v1 `orElse` v1 in
421 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
423 stricts = case idNewStrictness v of
424 StrictSig (DmdType _ demands _)
425 | listLengthCmp demands depth /= GT -> demands
426 -- length demands <= depth
428 -- If depth < length demands, then we have too few args to
429 -- satisfy strictness info so we have to ignore all the
430 -- strictness info, e.g. + (error "urk")
431 -- Here, we can't evaluate the arg strictly, because this
432 -- partial application might be seq'd
435 collect_args (Note (Coerce ty1 ty2) fun) depth
436 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
437 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
439 collect_args (Note note fun) depth
441 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
442 returnUs (Note note fun', hd, fun_ty, floats, ss)
444 -- non-variable fun, better let-bind it
445 collect_args fun depth
446 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
447 newVar ty `thenUs` \ fn_id ->
448 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
449 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
453 ignore_note InlineCall = True
454 ignore_note InlineMe = True
455 ignore_note _other = False
456 -- we don't ignore SCCs, since they require some code generation
458 ------------------------------------------------------------------------------
459 -- Building the saturated syntax
460 -- ---------------------------------------------------------------------------
462 -- maybeSaturate deals with saturating primops and constructors
463 -- The type is the type of the entire application
464 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
465 maybeSaturate fn expr n_args ty
466 | hasNoBinding fn = saturate_it
467 | otherwise = returnUs expr
469 fn_arity = idArity fn
470 excess_arity = fn_arity - n_args
471 saturate_it = getUniquesUs `thenUs` \ us ->
472 returnUs (etaExpand excess_arity us expr ty)
474 -- ---------------------------------------------------------------------------
475 -- Precipitating the floating bindings
476 -- ---------------------------------------------------------------------------
478 floatRhs :: TopLevelFlag -> RecFlag
480 -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
481 -> UniqSM (OrdList FloatingBind, -- Floats out of this bind
482 CoreExpr) -- Final Rhs
484 floatRhs top_lvl is_rec bndr (floats, rhs)
485 | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
486 allLazy top_lvl is_rec floats -- at top level
487 = -- Why the test for allLazy?
488 -- v = f (x `divInt#` y)
489 -- we don't want to float the case, even if f has arity 2,
490 -- because floating the case would make it evaluated too early
492 -- Finally, eta-expand the RHS, for the benefit of the code gen
493 returnUs (floats, rhs)
496 -- Don't float; the RHS isn't a value
497 = mkBinds floats rhs `thenUs` \ rhs' ->
498 returnUs (nilOL, rhs')
500 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
501 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
502 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
503 -> UniqSM (OrdList FloatingBind)
505 mkLocalNonRec bndr dem floats rhs
506 | isUnLiftedType (idType bndr)
507 -- If this is an unlifted binding, we always make a case for it.
508 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
510 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
512 returnUs (floats `snocOL` float)
515 -- It's a strict let so we definitely float all the bindings
516 = let -- Don't make a case for a value binding,
517 -- even if it's strict. Otherwise we get
518 -- case (\x -> e) of ...!
519 float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
520 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
522 returnUs (floats `snocOL` float)
525 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
526 returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
529 bndr_ty = idType bndr
530 bndr_rep_ty = repType bndr_ty
532 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
534 | isNilOL binds = returnUs body
535 | otherwise = deLam body `thenUs` \ body' ->
536 returnUs (foldrOL mk_bind body' binds)
538 mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
539 mk_bind (FloatLet bind) body = Let bind body
541 etaExpandRhs bndr rhs
542 = -- Eta expand to match the arity claimed by the binder
543 -- Remember, after CorePrep we must not change arity
545 -- Eta expansion might not have happened already,
546 -- because it is done by the simplifier only when
547 -- there at least one lambda already.
549 -- NB1:we could refrain when the RHS is trivial (which can happen
550 -- for exported things). This would reduce the amount of code
551 -- generated (a little) and make things a little words for
552 -- code compiled without -O. The case in point is data constructor
555 -- NB2: we have to be careful that the result of etaExpand doesn't
556 -- invalidate any of the assumptions that CorePrep is attempting
557 -- to establish. One possible cause is eta expanding inside of
558 -- an SCC note - we're now careful in etaExpand to make sure the
559 -- SCC is pushed inside any new lambdas that are generated.
561 -- NB3: It's important to do eta expansion, and *then* ANF-ising
562 -- f = /\a -> g (h 3) -- h has arity 2
563 -- If we ANF first we get
564 -- f = /\a -> let s = h 3 in g s
565 -- and now eta expansion gives
566 -- f = /\a -> \ y -> (let s = h 3 in g s) y
567 -- which is horrible.
568 -- Eta expanding first gives
569 -- f = /\a -> \y -> let s = h 3 in g s y
571 getUniquesUs `thenUs` \ us ->
572 returnUs (etaExpand arity us rhs (idType bndr))
574 -- For a GlobalId, take the Arity from the Id.
575 -- It was set in CoreTidy and must not change
576 -- For all others, just expand at will
577 arity | isGlobalId bndr = idArity bndr
578 | otherwise = exprArity rhs
580 -- ---------------------------------------------------------------------------
581 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
582 -- We arrange that they only show up as the RHS of a let(rec)
583 -- ---------------------------------------------------------------------------
585 deLam :: CoreExpr -> UniqSM CoreExpr
586 -- Remove top level lambdas by let-bindinig
589 = -- You can get things like
590 -- case e of { p -> coerce t (\s -> ...) }
591 deLam expr `thenUs` \ expr' ->
592 returnUs (Note n expr')
595 | null bndrs = returnUs expr
597 = case tryEta bndrs body of
598 Just no_lam_result -> returnUs no_lam_result
599 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
600 returnUs (Let (NonRec fn expr) (Var fn))
602 (bndrs,body) = collectBinders expr
604 -- Why try eta reduction? Hasn't the simplifier already done eta?
605 -- But the simplifier only eta reduces if that leaves something
606 -- trivial (like f, or f Int). But for deLam it would be enough to
607 -- get to a partial application, like (map f).
609 tryEta bndrs expr@(App _ _)
610 | ok_to_eta_reduce f &&
612 and (zipWith ok bndrs last_args) &&
613 not (any (`elemVarSet` fvs_remaining) bndrs)
614 = Just remaining_expr
616 (f, args) = collectArgs expr
617 remaining_expr = mkApps f remaining_args
618 fvs_remaining = exprFreeVars remaining_expr
619 (remaining_args, last_args) = splitAt n_remaining args
620 n_remaining = length args - length bndrs
622 ok bndr (Var arg) = bndr == arg
623 ok bndr other = False
625 -- we can't eta reduce something which must be saturated.
626 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
627 ok_to_eta_reduce _ = False --safe. ToDo: generalise
629 tryEta bndrs (Let bind@(NonRec b r) body)
630 | not (any (`elemVarSet` fvs) bndrs)
631 = case tryEta bndrs body of
632 Just e -> Just (Let bind e)
637 tryEta bndrs _ = Nothing
641 -- -----------------------------------------------------------------------------
642 -- Do the seq and par transformation
643 -- -----------------------------------------------------------------------------
645 Here we do two pre-codegen transformations:
651 case a of { DEFAULT -> rhs }
661 NB: seq# :: a -> Int# -- Evaluate value and return anything
662 par# :: a -> Int# -- Spark value and return anything
664 These transformations can't be done earlier, or else we might
665 think that the expression was strict in the variables in which
666 rhs is strict --- but that would defeat the purpose of seq and par.
670 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
671 -- DEFAULT alt is always first
672 = case isPrimOpId_maybe fn of
673 Just ParOp -> Case scrut bndr [deflt_alt]
674 Just SeqOp -> Case arg new_bndr [deflt_alt]
675 other -> Case scrut bndr alts
677 -- The binder shouldn't be used in the expression!
678 new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
679 setIdType bndr (exprType arg)
680 -- NB: SeqOp :: forall a. a -> Int#
681 -- So bndr has type Int#
682 -- But now we are going to scrutinise the SeqOp's argument directly,
683 -- so we must change the type of the case binder to match that
684 -- of the argument expression e.
686 mkCase scrut bndr alts = Case scrut bndr alts
690 -- -----------------------------------------------------------------------------
692 -- -----------------------------------------------------------------------------
696 = RhsDemand { isStrict :: Bool, -- True => used at least once
697 isOnceDem :: Bool -- True => used at most once
700 mkDem :: Demand -> Bool -> RhsDemand
701 mkDem strict once = RhsDemand (isStrictDmd strict) once
703 mkDemTy :: Demand -> Type -> RhsDemand
704 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
707 bdrDem :: Id -> RhsDemand
708 bdrDem id = mkDem (idNewDemandInfo id)
711 safeDem, onceDem :: RhsDemand
712 safeDem = RhsDemand False False -- always safe to use this
713 onceDem = RhsDemand False True -- used at most once
719 %************************************************************************
723 %************************************************************************
726 ------------------------------------------------------------------------------
728 -- ---------------------------------------------------------------------------
730 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
731 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
733 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
736 = getUniqueUs `thenUs` \ uniq ->
738 bndr' = setVarUnique bndr uniq
740 returnUs (extendVarEnv env bndr bndr', bndr')
742 | otherwise -- Top level things, which we don't want
743 -- to clone, have become GlobalIds by now
744 -- And we don't clone tyvars
745 = returnUs (env, bndr)
748 ------------------------------------------------------------------------------
749 -- Cloning ccall Ids; each must have a unique name,
750 -- to give the code generator a handle to hang it on
751 -- ---------------------------------------------------------------------------
753 fiddleCCall :: Id -> UniqSM Id
755 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
756 returnUs (id `setVarUnique` uniq)
757 | otherwise = returnUs id
759 ------------------------------------------------------------------------------
760 -- Generating new binders
761 -- ---------------------------------------------------------------------------
763 newVar :: Type -> UniqSM Id
766 getUniqueUs `thenUs` \ uniq ->
767 returnUs (mkSysLocal SLIT("sat") uniq ty)