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,
19 uaUTy, usOnce, usMany, eqUsage, seqType )
20 import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
21 import PrimOp ( PrimOp(..) )
22 import Var ( Var, Id, setVarUnique )
25 import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
26 setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
27 isLocalId, hasNoBinding, idNewStrictness,
28 isDataConId_maybe, idUnfolding
30 import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
31 import Unique ( mkBuiltinUnique )
32 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
40 import Util ( listLengthCmp )
44 -- ---------------------------------------------------------------------------
46 -- ---------------------------------------------------------------------------
48 The goal of this pass is to prepare for code generation.
50 1. Saturate constructor and primop applications.
52 2. Convert to A-normal form:
54 * Use case for strict arguments:
55 f E ==> case E of x -> f x
58 * Use let for non-trivial lazy arguments
59 f E ==> let x = E in f x
60 (were f is lazy and x is non-trivial)
62 3. Similarly, convert any unboxed lets into cases.
63 [I'm experimenting with leaving 'ok-for-speculation'
64 rhss in let-form right up to this point.]
66 4. Ensure that lambdas only occur as the RHS of a binding
67 (The code generator can't deal with anything else.)
69 5. Do the seq/par munging. See notes with mkCase below.
71 6. Clone all local Ids.
72 This means that all such Ids are unique, rather than the
73 weaker guarantee of no clashes which the simplifier provides.
74 And that is what the code generator needs.
76 We don't clone TyVars. The code gen doesn't need that,
77 and doing so would be tiresome because then we'd need
78 to substitute in types.
81 7. Give each dynamic CCall occurrence a fresh unique; this is
82 rather like the cloning step above.
84 8. Inject bindings for the "implicit" Ids:
85 * Constructor wrappers
88 We want curried definitions for all of these in case they
89 aren't inlined by some caller.
91 This is all done modulo type applications and abstractions, so that
92 when type erasure is done for conversion to STG, we don't end up with
93 any trivial or useless bindings.
97 -- -----------------------------------------------------------------------------
99 -- -----------------------------------------------------------------------------
102 corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
103 corePrepPgm dflags mod_details
104 = do showPass dflags "CorePrep"
105 us <- mkSplitUniqSupply 's'
107 let implicit_binds = mkImplicitBinds (md_types mod_details)
108 -- NB: we must feed mkImplicitBinds through corePrep too
109 -- so that they are suitably cloned and eta-expanded
111 binds_out = initUs_ us (
112 corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 ->
113 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
114 returnUs (deFloatTop (floats1 `appOL` floats2))
117 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
118 return (mod_details { md_binds = binds_out })
120 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
121 corePrepExpr dflags expr
122 = do showPass dflags "CorePrep"
123 us <- mkSplitUniqSupply 's'
124 let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
125 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
130 -- -----------------------------------------------------------------------------
132 -- -----------------------------------------------------------------------------
134 Create any necessary "implicit" bindings (data constructors etc).
136 * Constructor workers
137 * Constructor wrappers
138 * Data type record selectors
141 In the latter three cases, the Id contains the unfolding to use for
142 the binding. In the case of data con workers we create the rather
143 strange (non-recursive!) binding
145 $wC = \x y -> $wC x y
147 i.e. a curried constructor that allocates. This means that we can
148 treat the worker for a constructor like any other function in the rest
149 of the compiler. The point here is that CoreToStg will generate a
150 StgConApp for the RHS, rather than a call to the worker (which would
151 give a loop). As Lennart says: the ice is thin here, but it works.
153 Hmm. Should we create bindings for dictionary constructors? They are
154 always fully applied, and the bindings are just there to support
155 partial applications. But it's easier to let them through.
158 mkImplicitBinds type_env
159 = [ NonRec id (get_unfolding id)
160 | id <- implicitTyThingIds (typeEnvElts type_env) ]
161 -- The etaExpand is so that the manifest arity of the
162 -- binding matches its claimed arity, which is an
163 -- invariant of top level bindings going into the code gen
165 tmpl_uniqs = map mkBuiltinUnique [1..]
167 get_unfolding id -- See notes above
168 | Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works
169 | otherwise = unfoldingTemplate (idUnfolding id)
174 -- ---------------------------------------------------------------------------
175 -- Dealing with bindings
176 -- ---------------------------------------------------------------------------
178 data FloatingBind = FloatLet CoreBind
179 | FloatCase Id CoreExpr Bool
180 -- The bool indicates "ok-for-speculation"
182 instance Outputable FloatingBind where
183 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
184 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
186 type CloneEnv = IdEnv Id -- Clone local Ids
188 deFloatTop :: OrdList FloatingBind -> [CoreBind]
189 -- For top level only; we don't expect any FloatCases
191 = foldrOL get [] floats
193 get (FloatLet b) bs = b:bs
194 get b bs = pprPanic "corePrepPgm" (ppr b)
196 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
197 allLazy top_lvl is_rec floats
198 = foldrOL check True floats
200 unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
202 check (FloatLet _) y = y
203 check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
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 -- ---------------------------------------------------------------------------
211 -- ---------------------------------------------------------------------------
213 corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
214 corePrepTopBinds binds
215 = go emptyVarEnv binds
217 go env [] = returnUs nilOL
218 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
219 go env' binds `thenUs` \ binds' ->
220 returnUs (bind' `appOL` binds')
222 -- NB: we do need to float out of top-level bindings
223 -- Consider x = length [True,False]
229 -- We return a *list* of bindings, because we may start with
231 -- where x is demanded, in which case we want to finish with
234 -- And then x will actually end up case-bound
236 --------------------------------
237 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
238 corePrepTopBind env (NonRec bndr rhs)
239 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
240 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
241 returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
243 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
245 --------------------------------
246 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
247 -- This one is used for *local* bindings
248 corePrepBind env (NonRec bndr rhs)
249 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
250 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
251 cloneBndr env bndr `thenUs` \ (env', bndr') ->
252 mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
253 returnUs (env', floats')
255 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
257 --------------------------------
258 corePrepRecPairs :: TopLevelFlag -> CloneEnv
259 -> [(Id,CoreExpr)] -- Recursive bindings
260 -> UniqSM (CloneEnv, OrdList FloatingBind)
261 -- Used for all recursive bindings, top level and otherwise
262 corePrepRecPairs lvl env pairs
263 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
264 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
265 returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
267 -- Flatten all the floats, and the currrent
268 -- group into a single giant Rec
269 flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
271 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
272 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
274 --------------------------------
275 corePrepRhs :: TopLevelFlag -> RecFlag
276 -> CloneEnv -> (Id, CoreExpr)
277 -> UniqSM (OrdList FloatingBind, CoreExpr)
278 -- Used for top-level bindings, and local recursive bindings
279 corePrepRhs top_lvl is_rec env (bndr, rhs)
280 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
281 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
282 floatRhs top_lvl is_rec bndr floats_w_rhs
285 -- ---------------------------------------------------------------------------
286 -- Making arguments atomic (function args & constructor args)
287 -- ---------------------------------------------------------------------------
289 -- This is where we arrange that a non-trivial argument is let-bound
290 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
291 -> UniqSM (OrdList FloatingBind, CoreArg)
292 corePrepArg env arg dem
293 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
294 if exprIsTrivial arg'
295 then returnUs (floats, arg')
296 else newVar (exprType arg') `thenUs` \ v ->
297 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
298 returnUs (floats', Var v)
300 -- version that doesn't consider an scc annotation to be trivial.
301 exprIsTrivial (Var v) = True
302 exprIsTrivial (Type _) = True
303 exprIsTrivial (Lit lit) = True
304 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
305 exprIsTrivial (Note (SCC _) e) = False
306 exprIsTrivial (Note _ e) = exprIsTrivial e
307 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
308 exprIsTrivial other = False
310 -- ---------------------------------------------------------------------------
311 -- Dealing with expressions
312 -- ---------------------------------------------------------------------------
314 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
315 corePrepAnExpr env expr
316 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
320 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
324 -- e = let bs in e' (semantically, that is!)
327 -- f (g x) ===> ([v = g x], f v)
329 corePrepExprFloat env (Var v)
330 = fiddleCCall v `thenUs` \ v1 ->
331 let v2 = lookupVarEnv env v1 `orElse` v1 in
332 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
333 returnUs (nilOL, app)
335 corePrepExprFloat env expr@(Type _)
336 = returnUs (nilOL, expr)
338 corePrepExprFloat env expr@(Lit lit)
339 = returnUs (nilOL, expr)
341 corePrepExprFloat env (Let bind body)
342 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
343 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
344 returnUs (new_binds `appOL` floats, new_body)
346 corePrepExprFloat env (Note n@(SCC _) expr)
347 = corePrepAnExpr env expr `thenUs` \ expr1 ->
348 deLam expr1 `thenUs` \ expr2 ->
349 returnUs (nilOL, Note n expr2)
351 corePrepExprFloat env (Note other_note expr)
352 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
353 returnUs (floats, Note other_note expr')
355 corePrepExprFloat env expr@(Lam _ _)
356 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
357 corePrepAnExpr env' body `thenUs` \ body' ->
358 returnUs (nilOL, mkLams bndrs' body')
360 (bndrs,body) = collectBinders expr
362 corePrepExprFloat env (Case scrut bndr alts)
363 = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
364 cloneBndr env bndr `thenUs` \ (env', bndr') ->
365 mapUs (sat_alt env') alts `thenUs` \ alts' ->
366 returnUs (floats, mkCase scrut' bndr' alts')
368 sat_alt env (con, bs, rhs)
369 = cloneBndrs env bs `thenUs` \ (env', bs') ->
370 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
371 deLam rhs1 `thenUs` \ rhs2 ->
372 returnUs (con, bs', rhs2)
374 corePrepExprFloat env expr@(App _ _)
375 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
376 ASSERT(null ss) -- make sure we used all the strictness info
378 -- Now deal with the function
380 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
381 returnUs (floats, app')
383 _other -> returnUs (floats, app)
387 -- Deconstruct and rebuild the application, floating any non-atomic
388 -- arguments to the outside. We collect the type of the expression,
389 -- the head of the application, and the number of actual value arguments,
390 -- all of which are used to possibly saturate this application if it
391 -- has a constructor or primop at the head.
395 -> Int -- current app depth
396 -> UniqSM (CoreExpr, -- the rebuilt expression
397 (CoreExpr,Int), -- the head of the application,
398 -- and no. of args it was applied to
399 Type, -- type of the whole expr
400 OrdList FloatingBind, -- any floats we pulled out
401 [Demand]) -- remaining argument demands
403 collect_args (App fun arg@(Type arg_ty)) depth
404 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
405 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
407 collect_args (App fun arg) depth
408 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
410 (ss1, ss_rest) = case ss of
411 (ss1:ss_rest) -> (ss1, ss_rest)
413 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
414 splitFunTy_maybe fun_ty
416 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
417 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
419 collect_args (Var v) depth
420 = fiddleCCall v `thenUs` \ v1 ->
421 let v2 = lookupVarEnv env v1 `orElse` v1 in
422 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
424 stricts = case idNewStrictness v of
425 StrictSig (DmdType _ demands _)
426 | listLengthCmp demands depth /= GT -> demands
427 -- length demands <= depth
429 -- If depth < length demands, then we have too few args to
430 -- satisfy strictness info so we have to ignore all the
431 -- strictness info, e.g. + (error "urk")
432 -- Here, we can't evaluate the arg strictly, because this
433 -- partial application might be seq'd
436 collect_args (Note (Coerce ty1 ty2) fun) depth
437 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
438 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
440 collect_args (Note note fun) depth
442 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
443 returnUs (Note note fun', hd, fun_ty, floats, ss)
445 -- non-variable fun, better let-bind it
446 collect_args fun depth
447 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
448 newVar ty `thenUs` \ fn_id ->
449 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
450 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
454 ignore_note InlineCall = True
455 ignore_note InlineMe = True
456 ignore_note _other = False
457 -- we don't ignore SCCs, since they require some code generation
459 ------------------------------------------------------------------------------
460 -- Building the saturated syntax
461 -- ---------------------------------------------------------------------------
463 -- maybeSaturate deals with saturating primops and constructors
464 -- The type is the type of the entire application
465 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
466 maybeSaturate fn expr n_args ty
467 | hasNoBinding fn = saturate_it
468 | otherwise = returnUs expr
470 fn_arity = idArity fn
471 excess_arity = fn_arity - n_args
472 saturate_it = getUniquesUs `thenUs` \ us ->
473 returnUs (etaExpand excess_arity us expr ty)
475 -- ---------------------------------------------------------------------------
476 -- Precipitating the floating bindings
477 -- ---------------------------------------------------------------------------
479 floatRhs :: TopLevelFlag -> RecFlag
481 -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
482 -> UniqSM (OrdList FloatingBind, -- Floats out of this bind
483 CoreExpr) -- Final Rhs
485 floatRhs top_lvl is_rec bndr (floats, rhs)
486 | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
487 allLazy top_lvl is_rec floats -- at top level
488 = -- Why the test for allLazy?
489 -- v = f (x `divInt#` y)
490 -- we don't want to float the case, even if f has arity 2,
491 -- because floating the case would make it evaluated too early
493 -- Finally, eta-expand the RHS, for the benefit of the code gen
494 returnUs (floats, rhs)
497 -- Don't float; the RHS isn't a value
498 = mkBinds floats rhs `thenUs` \ rhs' ->
499 returnUs (nilOL, rhs')
501 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
502 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
503 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
504 -> UniqSM (OrdList FloatingBind)
506 mkLocalNonRec bndr dem floats rhs
507 | isUnLiftedType (idType bndr) || isStrict dem
508 -- It's a strict let, or the binder is unlifted,
509 -- so we definitely float all the bindings
510 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
511 let -- Don't make a case for a value binding,
512 -- even if it's strict. Otherwise we get
513 -- case (\x -> e) of ...!
514 float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
515 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
517 returnUs (floats `snocOL` float)
520 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
521 returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
524 bndr_ty = idType bndr
525 bndr_rep_ty = repType bndr_ty
527 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
529 | isNilOL binds = returnUs body
530 | otherwise = deLam body `thenUs` \ body' ->
531 returnUs (foldrOL mk_bind body' binds)
533 mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
534 mk_bind (FloatLet bind) body = Let bind body
536 etaExpandRhs bndr rhs
537 = -- Eta expand to match the arity claimed by the binder
538 -- Remember, after CorePrep we must not change arity
540 -- Eta expansion might not have happened already,
541 -- because it is done by the simplifier only when
542 -- there at least one lambda already.
544 -- NB1:we could refrain when the RHS is trivial (which can happen
545 -- for exported things). This would reduce the amount of code
546 -- generated (a little) and make things a little words for
547 -- code compiled without -O. The case in point is data constructor
550 -- NB2: we have to be careful that the result of etaExpand doesn't
551 -- invalidate any of the assumptions that CorePrep is attempting
552 -- to establish. One possible cause is eta expanding inside of
553 -- an SCC note - we're now careful in etaExpand to make sure the
554 -- SCC is pushed inside any new lambdas that are generated.
556 -- NB3: It's important to do eta expansion, and *then* ANF-ising
557 -- f = /\a -> g (h 3) -- h has arity 2
558 -- If we ANF first we get
559 -- f = /\a -> let s = h 3 in g s
560 -- and now eta expansion gives
561 -- f = /\a -> \ y -> (let s = h 3 in g s) y
562 -- which is horrible.
563 -- Eta expanding first gives
564 -- f = /\a -> \y -> let s = h 3 in g s y
566 getUniquesUs `thenUs` \ us ->
567 returnUs (etaExpand arity us rhs (idType bndr))
569 -- For a GlobalId, take the Arity from the Id.
570 -- It was set in CoreTidy and must not change
571 -- For all others, just expand at will
572 arity | isGlobalId bndr = idArity bndr
573 | otherwise = exprArity rhs
575 -- ---------------------------------------------------------------------------
576 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
577 -- We arrange that they only show up as the RHS of a let(rec)
578 -- ---------------------------------------------------------------------------
580 deLam :: CoreExpr -> UniqSM CoreExpr
581 -- Remove top level lambdas by let-bindinig
584 = -- You can get things like
585 -- case e of { p -> coerce t (\s -> ...) }
586 deLam expr `thenUs` \ expr' ->
587 returnUs (Note n expr')
590 | null bndrs = returnUs expr
592 = case tryEta bndrs body of
593 Just no_lam_result -> returnUs no_lam_result
594 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
595 returnUs (Let (NonRec fn expr) (Var fn))
597 (bndrs,body) = collectBinders expr
599 -- Why try eta reduction? Hasn't the simplifier already done eta?
600 -- But the simplifier only eta reduces if that leaves something
601 -- trivial (like f, or f Int). But for deLam it would be enough to
602 -- get to a partial application, like (map f).
604 tryEta bndrs expr@(App _ _)
605 | ok_to_eta_reduce f &&
607 and (zipWith ok bndrs last_args) &&
608 not (any (`elemVarSet` fvs_remaining) bndrs)
609 = Just remaining_expr
611 (f, args) = collectArgs expr
612 remaining_expr = mkApps f remaining_args
613 fvs_remaining = exprFreeVars remaining_expr
614 (remaining_args, last_args) = splitAt n_remaining args
615 n_remaining = length args - length bndrs
617 ok bndr (Var arg) = bndr == arg
618 ok bndr other = False
620 -- we can't eta reduce something which must be saturated.
621 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
622 ok_to_eta_reduce _ = False --safe. ToDo: generalise
624 tryEta bndrs (Let bind@(NonRec b r) body)
625 | not (any (`elemVarSet` fvs) bndrs)
626 = case tryEta bndrs body of
627 Just e -> Just (Let bind e)
632 tryEta bndrs _ = Nothing
636 -- -----------------------------------------------------------------------------
637 -- Do the seq and par transformation
638 -- -----------------------------------------------------------------------------
640 Here we do two pre-codegen transformations:
646 case a of { DEFAULT -> rhs }
656 NB: seq# :: a -> Int# -- Evaluate value and return anything
657 par# :: a -> Int# -- Spark value and return anything
659 These transformations can't be done earlier, or else we might
660 think that the expression was strict in the variables in which
661 rhs is strict --- but that would defeat the purpose of seq and par.
665 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
666 -- DEFAULT alt is always first
667 = case isPrimOpId_maybe fn of
668 Just ParOp -> Case scrut bndr [deflt_alt]
669 Just SeqOp -> Case arg new_bndr [deflt_alt]
670 other -> Case scrut bndr alts
672 -- The binder shouldn't be used in the expression!
673 new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
674 setIdType bndr (exprType arg)
675 -- NB: SeqOp :: forall a. a -> Int#
676 -- So bndr has type Int#
677 -- But now we are going to scrutinise the SeqOp's argument directly,
678 -- so we must change the type of the case binder to match that
679 -- of the argument expression e.
681 mkCase scrut bndr alts = Case scrut bndr alts
685 -- -----------------------------------------------------------------------------
687 -- -----------------------------------------------------------------------------
691 = RhsDemand { isStrict :: Bool, -- True => used at least once
692 isOnceDem :: Bool -- True => used at most once
695 mkDem :: Demand -> Bool -> RhsDemand
696 mkDem strict once = RhsDemand (isStrictDmd strict) once
698 mkDemTy :: Demand -> Type -> RhsDemand
699 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
701 isOnceTy :: Type -> Bool
705 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
710 once | u `eqUsage` usOnce = True
711 | u `eqUsage` usMany = False
712 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
714 bdrDem :: Id -> RhsDemand
715 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
717 safeDem, onceDem :: RhsDemand
718 safeDem = RhsDemand False False -- always safe to use this
719 onceDem = RhsDemand False True -- used at most once
725 %************************************************************************
729 %************************************************************************
732 ------------------------------------------------------------------------------
734 -- ---------------------------------------------------------------------------
736 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
737 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
739 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
742 = getUniqueUs `thenUs` \ uniq ->
744 bndr' = setVarUnique bndr uniq
746 returnUs (extendVarEnv env bndr bndr', bndr')
748 | otherwise -- Top level things, which we don't want
749 -- to clone, have become GlobalIds by now
750 -- And we don't clone tyvars
751 = returnUs (env, bndr)
754 ------------------------------------------------------------------------------
755 -- Cloning ccall Ids; each must have a unique name,
756 -- to give the code generator a handle to hang it on
757 -- ---------------------------------------------------------------------------
759 fiddleCCall :: Id -> UniqSM Id
761 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
762 returnUs (id `setVarUnique` uniq)
763 | otherwise = returnUs id
765 ------------------------------------------------------------------------------
766 -- Generating new binders
767 -- ---------------------------------------------------------------------------
769 newVar :: Type -> UniqSM Id
772 getUniqueUs `thenUs` \ uniq ->
773 returnUs (mkSysLocal SLIT("sat") uniq ty)