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( exprIsAtom, 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 hasNoBinding, idNewStrictness,
28 isDataConId_maybe, idUnfolding
30 import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
31 import Unique ( mkBuiltinUnique )
32 import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel,
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. This means that Tidy Core has the property
71 that all Ids are unique, rather than the weaker guarantee of
72 no clashes which the simplifier provides.
74 7. Give each dynamic CCall occurrence a fresh unique; this is
75 rather like the cloning step above.
77 8. Inject bindings for the "implicit" Ids:
78 * Constructor wrappers
81 We want curried definitions for all of these in case they
82 aren't inlined by some caller.
84 This is all done modulo type applications and abstractions, so that
85 when type erasure is done for conversion to STG, we don't end up with
86 any trivial or useless bindings.
90 -- -----------------------------------------------------------------------------
92 -- -----------------------------------------------------------------------------
95 corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
96 corePrepPgm dflags mod_details
97 = do showPass dflags "CorePrep"
98 us <- mkSplitUniqSupply 's'
100 let implicit_binds = mkImplicitBinds (md_types mod_details)
101 -- NB: we must feed mkImplicitBinds through corePrep too
102 -- so that they are suitably cloned and eta-expanded
104 binds_out = initUs_ us (
105 corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 ->
106 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
107 returnUs (deFloatTop (floats1 `appOL` floats2))
110 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
111 return (mod_details { md_binds = binds_out })
113 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
114 corePrepExpr dflags expr
115 = do showPass dflags "CorePrep"
116 us <- mkSplitUniqSupply 's'
117 let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
118 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
123 -- -----------------------------------------------------------------------------
125 -- -----------------------------------------------------------------------------
127 Create any necessary "implicit" bindings (data constructors etc).
129 * Constructor workers
130 * Constructor wrappers
131 * Data type record selectors
134 In the latter three cases, the Id contains the unfolding to use for
135 the binding. In the case of data con workers we create the rather
136 strange (non-recursive!) binding
138 $wC = \x y -> $wC x y
140 i.e. a curried constructor that allocates. This means that we can
141 treat the worker for a constructor like any other function in the rest
142 of the compiler. The point here is that CoreToStg will generate a
143 StgConApp for the RHS, rather than a call to the worker (which would
144 give a loop). As Lennart says: the ice is thin here, but it works.
146 Hmm. Should we create bindings for dictionary constructors? They are
147 always fully applied, and the bindings are just there to support
148 partial applications. But it's easier to let them through.
151 mkImplicitBinds type_env
152 = [ NonRec id (get_unfolding id)
153 | id <- implicitTyThingIds (typeEnvElts type_env) ]
154 -- The etaExpand is so that the manifest arity of the
155 -- binding matches its claimed arity, which is an
156 -- invariant of top level bindings going into the code gen
158 tmpl_uniqs = map mkBuiltinUnique [1..]
160 get_unfolding id -- See notes above
161 | Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works
162 | otherwise = unfoldingTemplate (idUnfolding id)
167 -- ---------------------------------------------------------------------------
168 -- Dealing with bindings
169 -- ---------------------------------------------------------------------------
171 data FloatingBind = FloatLet CoreBind
172 | FloatCase Id CoreExpr Bool
173 -- The bool indicates "ok-for-speculation"
175 instance Outputable FloatingBind where
176 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
177 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
179 type CloneEnv = IdEnv Id -- Clone local Ids
181 deFloatTop :: OrdList FloatingBind -> [CoreBind]
182 -- For top level only; we don't expect any FloatCases
184 = foldrOL get [] floats
186 get (FloatLet b) bs = b:bs
187 get b bs = pprPanic "corePrepPgm" (ppr b)
189 allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
190 allLazy top_lvl is_rec floats
191 = foldrOL check True floats
193 unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
195 check (FloatLet _) y = y
196 check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
197 -- The ok-for-speculation flag says that it's safe to
198 -- float this Case out of a let, and thereby do it more eagerly
199 -- We need the top-level flag because it's never ok to float
200 -- an unboxed binding to the top level
202 -- ---------------------------------------------------------------------------
204 -- ---------------------------------------------------------------------------
206 corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
207 corePrepTopBinds binds
208 = go emptyVarEnv binds
210 go env [] = returnUs nilOL
211 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
212 go env' binds `thenUs` \ binds' ->
213 returnUs (bind' `appOL` binds')
215 -- NB: we do need to float out of top-level bindings
216 -- Consider x = length [True,False]
222 -- We return a *list* of bindings, because we may start with
224 -- where x is demanded, in which case we want to finish with
227 -- And then x will actually end up case-bound
229 --------------------------------
230 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
231 corePrepTopBind env (NonRec bndr rhs)
232 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
233 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
234 returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
236 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
238 --------------------------------
239 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
240 -- This one is used for *local* bindings
241 corePrepBind env (NonRec bndr rhs)
242 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
243 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
244 cloneBndr env bndr `thenUs` \ (env', bndr') ->
245 mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
246 returnUs (env', floats')
248 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
250 --------------------------------
251 corePrepRecPairs :: TopLevelFlag -> CloneEnv
252 -> [(Id,CoreExpr)] -- Recursive bindings
253 -> UniqSM (CloneEnv, OrdList FloatingBind)
254 -- Used for all recursive bindings, top level and otherwise
255 corePrepRecPairs lvl env pairs
256 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
257 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
258 returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
260 -- Flatten all the floats, and the currrent
261 -- group into a single giant Rec
262 flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
264 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
265 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
267 --------------------------------
268 corePrepRhs :: TopLevelFlag -> RecFlag
269 -> CloneEnv -> (Id, CoreExpr)
270 -> UniqSM (OrdList FloatingBind, CoreExpr)
271 -- Used for top-level bindings, and local recursive bindings
272 corePrepRhs top_lvl is_rec env (bndr, rhs)
273 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
274 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
275 floatRhs top_lvl is_rec bndr floats_w_rhs
278 -- ---------------------------------------------------------------------------
279 -- Making arguments atomic (function args & constructor args)
280 -- ---------------------------------------------------------------------------
282 -- This is where we arrange that a non-trivial argument is let-bound
283 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
284 -> UniqSM (OrdList FloatingBind, CoreArg)
285 corePrepArg env arg dem
286 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
287 if exprIsTrivial arg'
288 then returnUs (floats, arg')
289 else newVar (exprType arg') `thenUs` \ v ->
290 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
291 returnUs (floats', Var v)
293 -- version that doesn't consider an scc annotation to be trivial.
294 exprIsTrivial (Var v) = True
295 exprIsTrivial (Type _) = True
296 exprIsTrivial (Lit lit) = True
297 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
298 exprIsTrivial (Note (SCC _) e) = False
299 exprIsTrivial (Note _ e) = exprIsTrivial e
300 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
301 exprIsTrivial other = False
303 -- ---------------------------------------------------------------------------
304 -- Dealing with expressions
305 -- ---------------------------------------------------------------------------
307 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
308 corePrepAnExpr env expr
309 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
313 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
317 -- e = let bs in e' (semantically, that is!)
320 -- f (g x) ===> ([v = g x], f v)
322 corePrepExprFloat env (Var v)
323 = fiddleCCall v `thenUs` \ v1 ->
324 let v2 = lookupVarEnv env v1 `orElse` v1 in
325 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
326 returnUs (nilOL, app)
328 corePrepExprFloat env expr@(Type _)
329 = returnUs (nilOL, expr)
331 corePrepExprFloat env expr@(Lit lit)
332 = returnUs (nilOL, expr)
334 corePrepExprFloat env (Let bind body)
335 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
336 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
337 returnUs (new_binds `appOL` floats, new_body)
339 corePrepExprFloat env (Note n@(SCC _) expr)
340 = corePrepAnExpr env expr `thenUs` \ expr1 ->
341 deLam expr1 `thenUs` \ expr2 ->
342 returnUs (nilOL, Note n expr2)
344 corePrepExprFloat env (Note other_note expr)
345 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
346 returnUs (floats, Note other_note expr')
348 corePrepExprFloat env expr@(Lam _ _)
349 = corePrepAnExpr env body `thenUs` \ body' ->
350 returnUs (nilOL, mkLams bndrs body')
352 (bndrs,body) = collectBinders expr
354 corePrepExprFloat env (Case scrut bndr alts)
355 = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
356 cloneBndr env bndr `thenUs` \ (env', bndr') ->
357 mapUs (sat_alt env') alts `thenUs` \ alts' ->
358 returnUs (floats, mkCase scrut' bndr' alts')
360 sat_alt env (con, bs, rhs)
361 = cloneBndrs env bs `thenUs` \ (env', bs') ->
362 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
363 deLam rhs1 `thenUs` \ rhs2 ->
364 returnUs (con, bs', rhs2)
366 corePrepExprFloat env expr@(App _ _)
367 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
368 ASSERT(null ss) -- make sure we used all the strictness info
370 -- Now deal with the function
372 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
373 returnUs (floats, app')
375 _other -> returnUs (floats, app)
379 -- Deconstruct and rebuild the application, floating any non-atomic
380 -- arguments to the outside. We collect the type of the expression,
381 -- the head of the application, and the number of actual value arguments,
382 -- all of which are used to possibly saturate this application if it
383 -- has a constructor or primop at the head.
387 -> Int -- current app depth
388 -> UniqSM (CoreExpr, -- the rebuilt expression
389 (CoreExpr,Int), -- the head of the application,
390 -- and no. of args it was applied to
391 Type, -- type of the whole expr
392 OrdList FloatingBind, -- any floats we pulled out
393 [Demand]) -- remaining argument demands
395 collect_args (App fun arg@(Type arg_ty)) depth
396 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
397 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
399 collect_args (App fun arg) depth
400 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
402 (ss1, ss_rest) = case ss of
403 (ss1:ss_rest) -> (ss1, ss_rest)
405 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
406 splitFunTy_maybe fun_ty
408 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
409 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
411 collect_args (Var v) depth
412 = fiddleCCall v `thenUs` \ v1 ->
413 let v2 = lookupVarEnv env v1 `orElse` v1 in
414 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
416 stricts = case idNewStrictness v of
417 StrictSig (DmdType _ demands _)
418 | depth >= length demands -> demands
420 -- If depth < length demands, then we have too few args to
421 -- satisfy strictness info so we have to ignore all the
422 -- strictness info, e.g. + (error "urk")
423 -- Here, we can't evaluate the arg strictly, because this
424 -- partial application might be seq'd
427 collect_args (Note (Coerce ty1 ty2) fun) depth
428 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
429 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
431 collect_args (Note note fun) depth
433 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
434 returnUs (Note note fun', hd, fun_ty, floats, ss)
436 -- non-variable fun, better let-bind it
437 collect_args fun depth
438 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
439 newVar ty `thenUs` \ fn_id ->
440 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
441 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
445 ignore_note InlineCall = True
446 ignore_note InlineMe = True
447 ignore_note _other = False
448 -- we don't ignore SCCs, since they require some code generation
450 ------------------------------------------------------------------------------
451 -- Building the saturated syntax
452 -- ---------------------------------------------------------------------------
454 -- maybeSaturate deals with saturating primops and constructors
455 -- The type is the type of the entire application
456 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
457 maybeSaturate fn expr n_args ty
458 | hasNoBinding fn = saturate_it
459 | otherwise = returnUs expr
461 fn_arity = idArity fn
462 excess_arity = fn_arity - n_args
463 saturate_it = getUniquesUs `thenUs` \ us ->
464 returnUs (etaExpand excess_arity us expr ty)
466 -- ---------------------------------------------------------------------------
467 -- Precipitating the floating bindings
468 -- ---------------------------------------------------------------------------
470 floatRhs :: TopLevelFlag -> RecFlag
472 -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
473 -> UniqSM (OrdList FloatingBind, -- Floats out of this bind
474 CoreExpr) -- Final Rhs
476 floatRhs top_lvl is_rec bndr (floats, rhs)
477 | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
478 allLazy top_lvl is_rec floats -- at top level
479 = -- Why the test for allLazy?
480 -- v = f (x `divInt#` y)
481 -- we don't want to float the case, even if f has arity 2,
482 -- because floating the case would make it evaluated too early
484 -- Finally, eta-expand the RHS, for the benefit of the code gen
485 returnUs (floats, rhs)
488 -- Don't float; the RHS isn't a value
489 = mkBinds floats rhs `thenUs` \ rhs' ->
490 returnUs (nilOL, rhs')
492 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
493 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
494 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
495 -> UniqSM (OrdList FloatingBind)
497 mkLocalNonRec bndr dem floats rhs
498 | isUnLiftedType (idType bndr) || isStrict dem
499 -- It's a strict let, or the binder is unlifted,
500 -- so we definitely float all the bindings
501 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
502 let -- Don't make a case for a value binding,
503 -- even if it's strict. Otherwise we get
504 -- case (\x -> e) of ...!
505 float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
506 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
508 returnUs (floats `snocOL` float)
511 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
512 returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
515 bndr_ty = idType bndr
516 bndr_rep_ty = repType bndr_ty
518 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
520 | isNilOL binds = returnUs body
521 | otherwise = deLam body `thenUs` \ body' ->
522 returnUs (foldrOL mk_bind body' binds)
524 mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
525 mk_bind (FloatLet bind) body = Let bind body
527 etaExpandRhs bndr rhs
528 = -- Eta expand to match the arity claimed by the binder
529 -- Remember, after CorePrep we must not change arity
531 -- Eta expansion might not have happened already,
532 -- because it is done by the simplifier only when
533 -- there at least one lambda already.
535 -- NB1:we could refrain when the RHS is trivial (which can happen
536 -- for exported things). This would reduce the amount of code
537 -- generated (a little) and make things a little words for
538 -- code compiled without -O. The case in point is data constructor
541 -- NB2: we have to be careful that the result of etaExpand doesn't
542 -- invalidate any of the assumptions that CorePrep is attempting
543 -- to establish. One possible cause is eta expanding inside of
544 -- an SCC note - we're now careful in etaExpand to make sure the
545 -- SCC is pushed inside any new lambdas that are generated.
547 -- NB3: It's important to do eta expansion, and *then* ANF-ising
548 -- f = /\a -> g (h 3) -- h has arity 2
549 -- If we ANF first we get
550 -- f = /\a -> let s = h 3 in g s
551 -- and now eta expansion gives
552 -- f = /\a -> \ y -> (let s = h 3 in g s) y
553 -- which is horrible.
554 -- Eta expanding first gives
555 -- f = /\a -> \y -> let s = h 3 in g s y
557 getUniquesUs `thenUs` \ us ->
558 returnUs (etaExpand arity us rhs (idType bndr))
560 -- For a GlobalId, take the Arity from the Id.
561 -- It was set in CoreTidy and must not change
562 -- For all others, just expand at will
563 arity | isGlobalId bndr = idArity bndr
564 | otherwise = exprArity rhs
566 -- ---------------------------------------------------------------------------
567 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
568 -- We arrange that they only show up as the RHS of a let(rec)
569 -- ---------------------------------------------------------------------------
571 deLam :: CoreExpr -> UniqSM CoreExpr
572 -- Remove top level lambdas by let-bindinig
575 = -- You can get things like
576 -- case e of { p -> coerce t (\s -> ...) }
577 deLam expr `thenUs` \ expr' ->
578 returnUs (Note n expr')
581 | null bndrs = returnUs expr
583 = case tryEta bndrs body of
584 Just no_lam_result -> returnUs no_lam_result
585 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
586 returnUs (Let (NonRec fn expr) (Var fn))
588 (bndrs,body) = collectBinders expr
590 -- Why try eta reduction? Hasn't the simplifier already done eta?
591 -- But the simplifier only eta reduces if that leaves something
592 -- trivial (like f, or f Int). But for deLam it would be enough to
593 -- get to a partial application, like (map f).
595 tryEta bndrs expr@(App _ _)
596 | ok_to_eta_reduce f &&
598 and (zipWith ok bndrs last_args) &&
599 not (any (`elemVarSet` fvs_remaining) bndrs)
600 = Just remaining_expr
602 (f, args) = collectArgs expr
603 remaining_expr = mkApps f remaining_args
604 fvs_remaining = exprFreeVars remaining_expr
605 (remaining_args, last_args) = splitAt n_remaining args
606 n_remaining = length args - length bndrs
608 ok bndr (Var arg) = bndr == arg
609 ok bndr other = False
611 -- we can't eta reduce something which must be saturated.
612 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
613 ok_to_eta_reduce _ = False --safe. ToDo: generalise
615 tryEta bndrs (Let bind@(NonRec b r) body)
616 | not (any (`elemVarSet` fvs) bndrs)
617 = case tryEta bndrs body of
618 Just e -> Just (Let bind e)
623 tryEta bndrs _ = Nothing
627 -- -----------------------------------------------------------------------------
628 -- Do the seq and par transformation
629 -- -----------------------------------------------------------------------------
631 Here we do two pre-codegen transformations:
637 case a of { DEFAULT -> rhs }
647 NB: seq# :: a -> Int# -- Evaluate value and return anything
648 par# :: a -> Int# -- Spark value and return anything
650 These transformations can't be done earlier, or else we might
651 think that the expression was strict in the variables in which
652 rhs is strict --- but that would defeat the purpose of seq and par.
656 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
657 -- DEFAULT alt is always first
658 = case isPrimOpId_maybe fn of
659 Just ParOp -> Case scrut bndr [deflt_alt]
660 Just SeqOp -> Case arg new_bndr [deflt_alt]
661 other -> Case scrut bndr alts
663 -- The binder shouldn't be used in the expression!
664 new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
665 setIdType bndr (exprType arg)
666 -- NB: SeqOp :: forall a. a -> Int#
667 -- So bndr has type Int#
668 -- But now we are going to scrutinise the SeqOp's argument directly,
669 -- so we must change the type of the case binder to match that
670 -- of the argument expression e.
672 mkCase scrut bndr alts = Case scrut bndr alts
676 -- -----------------------------------------------------------------------------
678 -- -----------------------------------------------------------------------------
682 = RhsDemand { isStrict :: Bool, -- True => used at least once
683 isOnceDem :: Bool -- True => used at most once
686 mkDem :: Demand -> Bool -> RhsDemand
687 mkDem strict once = RhsDemand (isStrictDmd strict) once
689 mkDemTy :: Demand -> Type -> RhsDemand
690 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
692 isOnceTy :: Type -> Bool
696 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
701 once | u `eqUsage` usOnce = True
702 | u `eqUsage` usMany = False
703 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
705 bdrDem :: Id -> RhsDemand
706 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
708 safeDem, onceDem :: RhsDemand
709 safeDem = RhsDemand False False -- always safe to use this
710 onceDem = RhsDemand False True -- used at most once
716 %************************************************************************
720 %************************************************************************
723 ------------------------------------------------------------------------------
725 -- ---------------------------------------------------------------------------
727 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
728 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
730 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
732 | isGlobalId bndr -- Top level things, which we don't want
733 = returnUs (env, bndr) -- to clone, have become GlobalIds by now
736 = getUniqueUs `thenUs` \ uniq ->
738 bndr' = setVarUnique bndr uniq
740 returnUs (extendVarEnv env bndr bndr', bndr')
742 ------------------------------------------------------------------------------
743 -- Cloning ccall Ids; each must have a unique name,
744 -- to give the code generator a handle to hang it on
745 -- ---------------------------------------------------------------------------
747 fiddleCCall :: Id -> UniqSM Id
749 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
750 returnUs (id `setVarUnique` uniq)
751 | otherwise = returnUs id
753 ------------------------------------------------------------------------------
754 -- Generating new binders
755 -- ---------------------------------------------------------------------------
757 newVar :: Type -> UniqSM Id
760 getUniqueUs `thenUs` \ uniq ->
761 returnUs (mkSysLocal SLIT("sat") uniq ty)