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, isLocalId,
27 hasNoBinding, idNewStrictness
29 import HscTypes ( ModDetails(..) )
38 -- ---------------------------------------------------------------------------
40 -- ---------------------------------------------------------------------------
42 The goal of this pass is to prepare for code generation.
44 1. Saturate constructor and primop applications.
46 2. Convert to A-normal form:
48 * Use case for strict arguments:
49 f E ==> case E of x -> f x
52 * Use let for non-trivial lazy arguments
53 f E ==> let x = E in f x
54 (were f is lazy and x is non-trivial)
56 3. Similarly, convert any unboxed lets into cases.
57 [I'm experimenting with leaving 'ok-for-speculation'
58 rhss in let-form right up to this point.]
60 4. Ensure that lambdas only occur as the RHS of a binding
61 (The code generator can't deal with anything else.)
63 5. Do the seq/par munging. See notes with mkCase below.
65 6. Clone all local Ids. This means that Tidy Core has the property
66 that all Ids are unique, rather than the weaker guarantee of
67 no clashes which the simplifier provides.
69 7. Give each dynamic CCall occurrence a fresh unique; this is
70 rather like the cloning step above.
72 This is all done modulo type applications and abstractions, so that
73 when type erasure is done for conversion to STG, we don't end up with
74 any trivial or useless bindings.
79 -- -----------------------------------------------------------------------------
81 -- -----------------------------------------------------------------------------
84 corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
85 corePrepPgm dflags mod_details
86 = do showPass dflags "CorePrep"
87 us <- mkSplitUniqSupply 's'
88 let new_binds = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
89 endPass dflags "CorePrep" Opt_D_dump_sat new_binds
90 return (mod_details { md_binds = new_binds })
92 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
93 corePrepExpr dflags expr
94 = do showPass dflags "CorePrep"
95 us <- mkSplitUniqSupply 's'
96 let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
97 dumpIfSet_dyn dflags Opt_D_dump_sat "CorePrep"
101 -- ---------------------------------------------------------------------------
102 -- Dealing with bindings
103 -- ---------------------------------------------------------------------------
105 data FloatingBind = FloatLet CoreBind
106 | FloatCase Id CoreExpr Bool
107 -- The bool indicates "ok-for-speculation"
109 instance Outputable FloatingBind where
110 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
111 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
113 type CloneEnv = IdEnv Id -- Clone local Ids
115 allLazy :: OrdList FloatingBind -> Bool
117 = foldrOL check True floats
119 check (FloatLet _) y = y
120 check (FloatCase _ _ ok_for_spec) y = ok_for_spec && y
121 -- The ok-for-speculation flag says that it's safe to
122 -- float this Case out of a let, and thereby do it more eagerly
123 -- We need the top-level flag because it's never ok to float
124 -- an unboxed binding to the top level
126 -- ---------------------------------------------------------------------------
128 -- ---------------------------------------------------------------------------
130 corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
131 corePrepTopBinds env [] = returnUs []
133 corePrepTopBinds env (bind : binds)
134 = corePrepTopBind env bind `thenUs` \ (env', bind') ->
135 corePrepTopBinds env' binds `thenUs` \ binds' ->
136 returnUs (bind' : binds')
138 -- From top level bindings we don't get any floats
139 -- (a) it isn't necessary because the mkAtomicArgs in Simplify
140 -- has already done all the floating necessary
141 -- (b) floating would give rise to top-level LocaIds, generated
142 -- by CorePrep.newVar. That breaks the invariant that
143 -- after CorePrep all top-level vars are GlobalIds
145 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, CoreBind)
146 corePrepTopBind env (NonRec bndr rhs)
147 = corePrepRhs env (bndr, rhs) `thenUs` \ rhs' ->
148 cloneBndr env bndr `thenUs` \ (env', bndr') ->
149 returnUs (env', NonRec bndr' rhs')
151 corePrepTopBind env (Rec pairs)
152 = corePrepRecPairs env pairs `thenUs` \ (env', pairs') ->
153 returnUs (env, Rec pairs')
155 corePrepRecPairs env pairs
156 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
157 mapUs (corePrepRhs env') pairs `thenUs` \ rhss' ->
158 returnUs (env', bndrs' `zip` rhss')
160 bndrs = map fst pairs
162 corePrepRhs :: CloneEnv -> (Id, CoreExpr) -> UniqSM CoreExpr
163 -- Used for top-level bindings, and local recursive bindings
164 -- c.f. mkLocalNonRec, which does the other case
165 -- No nonsense about floating.
166 -- Prepare the RHS and eta expand it.
167 corePrepRhs env (bndr, rhs)
168 = corePrepAnExpr env rhs `thenUs` \ rhs' ->
169 getUniquesUs `thenUs` \ us ->
170 returnUs (etaExpand (exprArity rhs') us rhs' (idType bndr))
173 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
174 -- This one is used for *local* bindings
175 -- We return a *list* of bindings, because we may start with
177 -- where x is demanded, in which case we want to finish with
180 -- And then x will actually end up case-bound
182 corePrepBind env (NonRec bndr rhs)
183 = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
184 cloneBndr env bndr `thenUs` \ (env', bndr') ->
185 mkLocalNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
186 returnUs (env', floats')
188 corePrepBind env (Rec pairs)
189 -- Don't bother to try to float bindings out of RHSs
190 -- (compare mkNonRec, which does try)
191 = corePrepRecPairs env pairs `thenUs` \ (env', pairs') ->
192 returnUs (env', unitOL (FloatLet (Rec pairs')))
194 -- ---------------------------------------------------------------------------
195 -- Making arguments atomic (function args & constructor args)
196 -- ---------------------------------------------------------------------------
198 -- This is where we arrange that a non-trivial argument is let-bound
199 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
200 -> UniqSM (OrdList FloatingBind, CoreArg)
201 corePrepArg env arg dem
202 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
203 if needs_binding arg'
204 then returnUs (floats, arg')
205 else newVar (exprType arg') `thenUs` \ v ->
206 mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
207 returnUs (floats', Var v)
209 needs_binding | opt_RuntimeTypes = exprIsAtom
210 | otherwise = exprIsTrivial
212 -- version that doesn't consider an scc annotation to be trivial.
213 exprIsTrivial (Var v)
214 | hasNoBinding v = idArity v == 0
216 exprIsTrivial (Type _) = True
217 exprIsTrivial (Lit lit) = True
218 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
219 exprIsTrivial (Note (SCC _) e) = False
220 exprIsTrivial (Note _ e) = exprIsTrivial e
221 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
222 exprIsTrivial other = False
224 -- ---------------------------------------------------------------------------
225 -- Dealing with expressions
226 -- ---------------------------------------------------------------------------
228 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
229 corePrepAnExpr env expr
230 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
234 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
238 -- e = let bs in e' (semantically, that is!)
241 -- f (g x) ===> ([v = g x], f v)
243 corePrepExprFloat env (Var v)
244 = fiddleCCall v `thenUs` \ v1 ->
245 let v2 = lookupVarEnv env v1 `orElse` v1 in
246 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
247 returnUs (nilOL, app)
249 corePrepExprFloat env expr@(Type _)
250 = returnUs (nilOL, expr)
252 corePrepExprFloat env expr@(Lit lit)
253 = returnUs (nilOL, expr)
255 corePrepExprFloat env (Let bind body)
256 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
257 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
258 returnUs (new_binds `appOL` floats, new_body)
260 corePrepExprFloat env (Note n@(SCC _) expr)
261 = corePrepAnExpr env expr `thenUs` \ expr1 ->
262 deLam expr1 `thenUs` \ expr2 ->
263 returnUs (nilOL, Note n expr2)
265 corePrepExprFloat env (Note other_note expr)
266 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
267 returnUs (floats, Note other_note expr')
269 corePrepExprFloat env expr@(Lam _ _)
270 = corePrepAnExpr env body `thenUs` \ body' ->
271 returnUs (nilOL, mkLams bndrs body')
273 (bndrs,body) = collectBinders expr
275 corePrepExprFloat env (Case scrut bndr alts)
276 = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
277 cloneBndr env bndr `thenUs` \ (env', bndr') ->
278 mapUs (sat_alt env') alts `thenUs` \ alts' ->
279 returnUs (floats, mkCase scrut' bndr' alts')
281 sat_alt env (con, bs, rhs)
282 = cloneBndrs env bs `thenUs` \ (env', bs') ->
283 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
284 deLam rhs1 `thenUs` \ rhs2 ->
285 returnUs (con, bs', rhs2)
287 corePrepExprFloat env expr@(App _ _)
288 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
289 ASSERT(null ss) -- make sure we used all the strictness info
291 -- Now deal with the function
293 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
294 returnUs (floats, app')
296 _other -> returnUs (floats, app)
300 -- Deconstruct and rebuild the application, floating any non-atomic
301 -- arguments to the outside. We collect the type of the expression,
302 -- the head of the application, and the number of actual value arguments,
303 -- all of which are used to possibly saturate this application if it
304 -- has a constructor or primop at the head.
308 -> Int -- current app depth
309 -> UniqSM (CoreExpr, -- the rebuilt expression
310 (CoreExpr,Int), -- the head of the application,
311 -- and no. of args it was applied to
312 Type, -- type of the whole expr
313 OrdList FloatingBind, -- any floats we pulled out
314 [Demand]) -- remaining argument demands
316 collect_args (App fun arg@(Type arg_ty)) depth
317 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
318 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
320 collect_args (App fun arg) depth
321 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
323 (ss1, ss_rest) = case ss of
324 (ss1:ss_rest) -> (ss1, ss_rest)
326 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
327 splitFunTy_maybe fun_ty
329 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
330 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
332 collect_args (Var v) depth
333 = fiddleCCall v `thenUs` \ v1 ->
334 let v2 = lookupVarEnv env v1 `orElse` v1 in
335 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
337 stricts = case idNewStrictness v of
338 StrictSig (DmdType _ demands _)
339 | depth >= length demands -> demands
341 -- If depth < length demands, then we have too few args to
342 -- satisfy strictness info so we have to ignore all the
343 -- strictness info, e.g. + (error "urk")
344 -- Here, we can't evaluate the arg strictly, because this
345 -- partial application might be seq'd
348 collect_args (Note (Coerce ty1 ty2) fun) depth
349 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
350 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
352 collect_args (Note note fun) depth
354 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
355 returnUs (Note note fun', hd, fun_ty, floats, ss)
357 -- non-variable fun, better let-bind it
358 collect_args fun depth
359 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
360 newVar ty `thenUs` \ fn_id ->
361 mkLocalNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
362 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
366 ignore_note InlineCall = True
367 ignore_note InlineMe = True
368 ignore_note _other = False
369 -- we don't ignore SCCs, since they require some code generation
371 ------------------------------------------------------------------------------
372 -- Building the saturated syntax
373 -- ---------------------------------------------------------------------------
375 -- maybeSaturate deals with saturating primops and constructors
376 -- The type is the type of the entire application
377 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
378 maybeSaturate fn expr n_args ty
379 | hasNoBinding fn = saturate_it
380 | otherwise = returnUs expr
382 fn_arity = idArity fn
383 excess_arity = fn_arity - n_args
384 saturate_it = getUniquesUs `thenUs` \ us ->
385 returnUs (etaExpand excess_arity us expr ty)
387 -- ---------------------------------------------------------------------------
388 -- Precipitating the floating bindings
389 -- ---------------------------------------------------------------------------
391 -- mkLocalNonRec is used only for local bindings
392 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
393 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
394 -> UniqSM (OrdList FloatingBind)
396 mkLocalNonRec bndr dem floats rhs
397 | exprIsValue rhs && allLazy floats -- Notably constructor applications
398 = -- Why the test for allLazy? You might think that the only
399 -- floats we can get out of a value are eta expansions
400 -- e.g. C $wJust ==> let s = \x -> $wJust x in C s
401 -- Here we want to float the s binding.
403 -- But if the programmer writes this:
404 -- f x = case x of { (a,b) -> \y -> a }
405 -- then the strictness analyser may say that f has strictness "S"
406 -- Later the eta expander will transform to
407 -- f x y = case x of { (a,b) -> a }
408 -- So now f has arity 2. Now CorePrep may see
410 -- so the E argument will turn into a FloatCase.
411 -- Indeed we should end up with
412 -- v = case E of { r -> f r }
413 -- That is, we should not float, even though (f r) is a value
416 -- v = f (x `divInt#` y)
417 -- we don't want to float the case, even if f has arity 2,
418 -- because floating the case would make it evaluated too early
420 -- Finally, eta-expand the RHS, for the benefit of the code gen
421 -- This might not have happened already, because eta expansion
422 -- is done by the simplifier only when there at least one lambda already.
424 -- NB: we could refrain when the RHS is trivial (which can happen
425 -- for exported things. This would reduce the amount of code
426 -- generated (a little) and make things a little words for
427 -- code compiled without -O. The case in point is data constructor
430 getUniquesUs `thenUs` \ us ->
432 rhs' = etaExpand (exprArity rhs) us rhs bndr_ty
434 returnUs (floats `snocOL` FloatLet (NonRec bndr rhs'))
436 | isUnLiftedType bndr_rep_ty || isStrict dem
437 -- It's a strict let, or the binder is unlifted,
438 -- so we definitely float all the bindings
439 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
440 returnUs (floats `snocOL` FloatCase bndr rhs (exprOkForSpeculation rhs))
443 -- Don't float; the RHS isn't a value
444 = mkBinds floats rhs `thenUs` \ rhs' ->
445 returnUs (unitOL (FloatLet (NonRec bndr rhs')))
448 bndr_ty = idType bndr
449 bndr_rep_ty = repType bndr_ty
451 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
453 | isNilOL binds = returnUs body
454 | otherwise = deLam body `thenUs` \ body' ->
455 returnUs (foldrOL mk_bind body' binds)
457 mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
458 mk_bind (FloatLet bind) body = Let bind body
460 -- ---------------------------------------------------------------------------
461 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
462 -- We arrange that they only show up as the RHS of a let(rec)
463 -- ---------------------------------------------------------------------------
465 deLam :: CoreExpr -> UniqSM CoreExpr
466 -- Remove top level lambdas by let-bindinig
469 = -- You can get things like
470 -- case e of { p -> coerce t (\s -> ...) }
471 deLam expr `thenUs` \ expr' ->
472 returnUs (Note n expr')
475 | null bndrs = returnUs expr
476 | otherwise = case tryEta bndrs body of
477 Just no_lam_result -> returnUs no_lam_result
478 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
479 returnUs (Let (NonRec fn expr) (Var fn))
481 (bndrs,body) = collectBinders expr
483 -- Why try eta reduction? Hasn't the simplifier already done eta?
484 -- But the simplifier only eta reduces if that leaves something
485 -- trivial (like f, or f Int). But for deLam it would be enough to
486 -- get to a partial application, like (map f).
488 tryEta bndrs expr@(App _ _)
489 | ok_to_eta_reduce f &&
491 and (zipWith ok bndrs last_args) &&
492 not (any (`elemVarSet` fvs_remaining) bndrs)
493 = Just remaining_expr
495 (f, args) = collectArgs expr
496 remaining_expr = mkApps f remaining_args
497 fvs_remaining = exprFreeVars remaining_expr
498 (remaining_args, last_args) = splitAt n_remaining args
499 n_remaining = length args - length bndrs
501 ok bndr (Var arg) = bndr == arg
502 ok bndr other = False
504 -- we can't eta reduce something which must be saturated.
505 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
506 ok_to_eta_reduce _ = False --safe. ToDo: generalise
508 tryEta bndrs (Let bind@(NonRec b r) body)
509 | not (any (`elemVarSet` fvs) bndrs)
510 = case tryEta bndrs body of
511 Just e -> Just (Let bind e)
516 tryEta bndrs _ = Nothing
520 -- -----------------------------------------------------------------------------
521 -- Do the seq and par transformation
522 -- -----------------------------------------------------------------------------
524 Here we do two pre-codegen transformations:
530 case a of { DEFAULT -> rhs }
540 NB: seq# :: a -> Int# -- Evaluate value and return anything
541 par# :: a -> Int# -- Spark value and return anything
543 These transformations can't be done earlier, or else we might
544 think that the expression was strict in the variables in which
545 rhs is strict --- but that would defeat the purpose of seq and par.
549 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
550 -- DEFAULT alt is always first
551 = case isPrimOpId_maybe fn of
552 Just ParOp -> Case scrut bndr [deflt_alt]
553 Just SeqOp -> Case arg new_bndr [deflt_alt]
554 other -> Case scrut bndr alts
556 -- The binder shouldn't be used in the expression!
557 new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
558 setIdType bndr (exprType arg)
559 -- NB: SeqOp :: forall a. a -> Int#
560 -- So bndr has type Int#
561 -- But now we are going to scrutinise the SeqOp's argument directly,
562 -- so we must change the type of the case binder to match that
563 -- of the argument expression e.
565 mkCase scrut bndr alts = Case scrut bndr alts
569 -- -----------------------------------------------------------------------------
571 -- -----------------------------------------------------------------------------
575 = RhsDemand { isStrict :: Bool, -- True => used at least once
576 isOnceDem :: Bool -- True => used at most once
579 mkDem :: Demand -> Bool -> RhsDemand
580 mkDem strict once = RhsDemand (isStrictDmd strict) once
582 mkDemTy :: Demand -> Type -> RhsDemand
583 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
585 isOnceTy :: Type -> Bool
589 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
594 once | u `eqUsage` usOnce = True
595 | u `eqUsage` usMany = False
596 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
598 bdrDem :: Id -> RhsDemand
599 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
601 safeDem, onceDem :: RhsDemand
602 safeDem = RhsDemand False False -- always safe to use this
603 onceDem = RhsDemand False True -- used at most once
609 %************************************************************************
613 %************************************************************************
616 ------------------------------------------------------------------------------
618 -- ---------------------------------------------------------------------------
620 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
621 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
623 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
625 | isId bndr && isLocalId bndr -- Top level things, which we don't want
626 -- to clone, have become GlobalIds by now
627 = getUniqueUs `thenUs` \ uniq ->
629 bndr' = setVarUnique bndr uniq
631 returnUs (extendVarEnv env bndr bndr', bndr')
633 | otherwise = returnUs (env, bndr)
635 ------------------------------------------------------------------------------
636 -- Cloning ccall Ids; each must have a unique name,
637 -- to give the code generator a handle to hang it on
638 -- ---------------------------------------------------------------------------
640 fiddleCCall :: Id -> UniqSM Id
642 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
643 returnUs (id `setVarUnique` uniq)
644 | otherwise = returnUs id
646 ------------------------------------------------------------------------------
647 -- Generating new binders
648 -- ---------------------------------------------------------------------------
650 newVar :: Type -> UniqSM Id
652 = getUniqueUs `thenUs` \ uniq ->
654 returnUs (mkSysLocal SLIT("sat") uniq ty)