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 )
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
108 type CloneEnv = IdEnv Id -- Clone local Ids
110 allLazy :: OrdList FloatingBind -> Bool
111 allLazy floats = foldOL check True floats
113 check (FloatLet _) y = y
114 check (FloatCase _ _) y = False
116 corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
117 corePrepTopBinds env [] = returnUs []
119 corePrepTopBinds env (bind : binds)
120 = corePrepBind env bind `thenUs` \ (env', floats) ->
121 ASSERT( allLazy floats )
122 corePrepTopBinds env' binds `thenUs` \ binds' ->
123 returnUs (foldOL add binds' floats)
125 add (FloatLet bind) binds = bind : binds
128 -- ---------------------------------------------------------------------------
130 -- ---------------------------------------------------------------------------
132 corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
133 -- Used for non-top-level bindings
134 -- We return a *list* of bindings, because we may start with
136 -- where x is demanded, in which case we want to finish with
139 -- And then x will actually end up case-bound
141 corePrepBind env (NonRec bndr rhs)
142 = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
143 cloneBndr env bndr `thenUs` \ (env', bndr') ->
144 mkNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
145 returnUs (env', floats')
147 corePrepBind env (Rec pairs)
148 -- Don't bother to try to float bindings out of RHSs
149 -- (compare mkNonRec, which does try)
150 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
151 mapUs (corePrepAnExpr env') rhss `thenUs` \ rhss' ->
152 returnUs (env', unitOL (FloatLet (Rec (bndrs' `zip` rhss'))))
154 (bndrs, rhss) = unzip pairs
157 -- ---------------------------------------------------------------------------
158 -- Making arguments atomic (function args & constructor args)
159 -- ---------------------------------------------------------------------------
161 -- This is where we arrange that a non-trivial argument is let-bound
162 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
163 -> UniqSM (OrdList FloatingBind, CoreArg)
164 corePrepArg env arg dem
165 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
166 if needs_binding arg'
167 then returnUs (floats, arg')
168 else newVar (exprType arg') `thenUs` \ v ->
169 mkNonRec v dem floats arg' `thenUs` \ floats' ->
170 returnUs (floats', Var v)
172 needs_binding | opt_RuntimeTypes = exprIsAtom
173 | otherwise = exprIsTrivial
175 -- version that doesn't consider an scc annotation to be trivial.
176 exprIsTrivial (Var v)
177 | hasNoBinding v = idArity v == 0
179 exprIsTrivial (Type _) = True
180 exprIsTrivial (Lit lit) = True
181 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
182 exprIsTrivial (Note (SCC _) e) = False
183 exprIsTrivial (Note _ e) = exprIsTrivial e
184 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
185 exprIsTrivial other = False
187 -- ---------------------------------------------------------------------------
188 -- Dealing with expressions
189 -- ---------------------------------------------------------------------------
191 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
192 corePrepAnExpr env expr
193 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
197 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
201 -- e = let bs in e' (semantically, that is!)
204 -- f (g x) ===> ([v = g x], f v)
206 corePrepExprFloat env (Var v)
207 = fiddleCCall v `thenUs` \ v1 ->
208 let v2 = lookupVarEnv env v1 `orElse` v1 in
209 maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
210 returnUs (nilOL, app)
212 corePrepExprFloat env expr@(Type _)
213 = returnUs (nilOL, expr)
215 corePrepExprFloat env expr@(Lit lit)
216 = returnUs (nilOL, expr)
218 corePrepExprFloat env (Let bind body)
219 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
220 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
221 returnUs (new_binds `appOL` floats, new_body)
223 corePrepExprFloat env (Note n@(SCC _) expr)
224 = corePrepAnExpr env expr `thenUs` \ expr1 ->
225 deLam expr1 `thenUs` \ expr2 ->
226 returnUs (nilOL, Note n expr2)
228 corePrepExprFloat env (Note other_note expr)
229 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
230 returnUs (floats, Note other_note expr')
232 corePrepExprFloat env expr@(Lam _ _)
233 = corePrepAnExpr env body `thenUs` \ body' ->
234 returnUs (nilOL, mkLams bndrs body')
236 (bndrs,body) = collectBinders expr
238 corePrepExprFloat env (Case scrut bndr alts)
239 = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
240 cloneBndr env bndr `thenUs` \ (env', bndr') ->
241 mapUs (sat_alt env') alts `thenUs` \ alts' ->
242 returnUs (floats, mkCase scrut' bndr' alts')
244 sat_alt env (con, bs, rhs)
245 = cloneBndrs env bs `thenUs` \ (env', bs') ->
246 corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
247 deLam rhs1 `thenUs` \ rhs2 ->
248 returnUs (con, bs', rhs2)
250 corePrepExprFloat env expr@(App _ _)
251 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
252 ASSERT(null ss) -- make sure we used all the strictness info
254 -- Now deal with the function
256 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
257 returnUs (floats, app')
259 _other -> returnUs (floats, app)
263 -- Deconstruct and rebuild the application, floating any non-atomic
264 -- arguments to the outside. We collect the type of the expression,
265 -- the head of the application, and the number of actual value arguments,
266 -- all of which are used to possibly saturate this application if it
267 -- has a constructor or primop at the head.
271 -> Int -- current app depth
272 -> UniqSM (CoreExpr, -- the rebuilt expression
273 (CoreExpr,Int), -- the head of the application,
274 -- and no. of args it was applied to
275 Type, -- type of the whole expr
276 OrdList FloatingBind, -- any floats we pulled out
277 [Demand]) -- remaining argument demands
279 collect_args (App fun arg@(Type arg_ty)) depth
280 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
281 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
283 collect_args (App fun arg) depth
284 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
286 (ss1, ss_rest) = case ss of
287 (ss1:ss_rest) -> (ss1, ss_rest)
289 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
290 splitFunTy_maybe fun_ty
292 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
293 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
295 collect_args (Var v) depth
296 = fiddleCCall v `thenUs` \ v1 ->
297 let v2 = lookupVarEnv env v1 `orElse` v1 in
298 returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
300 stricts = case idNewStrictness v of
301 StrictSig (DmdType _ demands _)
302 | depth >= length demands -> demands
304 -- If depth < length demands, then we have too few args to
305 -- satisfy strictness info so we have to ignore all the
306 -- strictness info, e.g. + (error "urk")
307 -- Here, we can't evaluate the arg strictly, because this
308 -- partial application might be seq'd
311 collect_args (Note (Coerce ty1 ty2) fun) depth
312 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
313 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
315 collect_args (Note note fun) depth
317 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
318 returnUs (Note note fun', hd, fun_ty, floats, ss)
320 -- non-variable fun, better let-bind it
321 collect_args fun depth
322 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
323 newVar ty `thenUs` \ fn_id ->
324 mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
325 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
329 ignore_note InlineCall = True
330 ignore_note InlineMe = True
331 ignore_note _other = False
332 -- we don't ignore SCCs, since they require some code generation
334 ------------------------------------------------------------------------------
335 -- Building the saturated syntax
336 -- ---------------------------------------------------------------------------
338 -- maybeSaturate deals with saturating primops and constructors
339 -- The type is the type of the entire application
340 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
341 maybeSaturate fn expr n_args ty
342 | hasNoBinding fn = saturate_it
343 | otherwise = returnUs expr
345 fn_arity = idArity fn
346 excess_arity = fn_arity - n_args
347 saturate_it = getUs `thenUs` \ us ->
348 returnUs (etaExpand excess_arity us expr ty)
350 -- ---------------------------------------------------------------------------
351 -- Precipitating the floating bindings
352 -- ---------------------------------------------------------------------------
354 -- mkNonRec is used for both top level and local bindings
355 mkNonRec :: Id -> RhsDemand -- Lhs: id with demand
356 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
357 -> UniqSM (OrdList FloatingBind)
358 mkNonRec bndr dem floats rhs
359 | exprIsValue rhs && allLazy floats -- Notably constructor applications
360 = -- Why the test for allLazy? You might think that the only
361 -- floats we can get out of a value are eta expansions
362 -- e.g. C $wJust ==> let s = \x -> $wJust x in C s
363 -- Here we want to float the s binding.
365 -- But if the programmer writes this:
366 -- f x = case x of { (a,b) -> \y -> a }
367 -- then the strictness analyser may say that f has strictness "S"
368 -- Later the eta expander will transform to
369 -- f x y = case x of { (a,b) -> a }
370 -- So now f has arity 2. Now CorePrep may see
372 -- so the E argument will turn into a FloatCase.
373 -- Indeed we should end up with
374 -- v = case E of { r -> f r }
375 -- That is, we should not float, even though (f r) is a value
378 -- v = f (x `divInt#` y)
379 -- we don't want to float the case, even if f has arity 2,
380 -- because floating the case would make it evaluated too early
381 returnUs (floats `snocOL` FloatLet (NonRec bndr rhs))
383 | isUnLiftedType bndr_rep_ty || isStrict dem
384 -- It's a strict let, or the binder is unlifted,
385 -- so we definitely float all the bindings
386 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
387 returnUs (floats `snocOL` FloatCase bndr rhs)
391 = mkBinds floats rhs `thenUs` \ rhs' ->
392 returnUs (unitOL (FloatLet (NonRec bndr rhs')))
395 bndr_rep_ty = repType (idType bndr)
397 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
399 | isNilOL binds = returnUs body
400 | otherwise = deLam body `thenUs` \ body' ->
401 returnUs (foldOL mk_bind body' binds)
403 mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
404 mk_bind (FloatLet bind) body = Let bind body
406 -- ---------------------------------------------------------------------------
407 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
408 -- We arrange that they only show up as the RHS of a let(rec)
409 -- ---------------------------------------------------------------------------
411 deLam :: CoreExpr -> UniqSM CoreExpr
412 -- Remove top level lambdas by let-bindinig
415 = -- You can get things like
416 -- case e of { p -> coerce t (\s -> ...) }
417 deLam expr `thenUs` \ expr' ->
418 returnUs (Note n expr')
421 | null bndrs = returnUs expr
422 | otherwise = case tryEta bndrs body of
423 Just no_lam_result -> returnUs no_lam_result
424 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
425 returnUs (Let (NonRec fn expr) (Var fn))
427 (bndrs,body) = collectBinders expr
429 -- Why try eta reduction? Hasn't the simplifier already done eta?
430 -- But the simplifier only eta reduces if that leaves something
431 -- trivial (like f, or f Int). But for deLam it would be enough to
432 -- get to a partial application, like (map f).
434 tryEta bndrs expr@(App _ _)
435 | ok_to_eta_reduce f &&
437 and (zipWith ok bndrs last_args) &&
438 not (any (`elemVarSet` fvs_remaining) bndrs)
439 = Just remaining_expr
441 (f, args) = collectArgs expr
442 remaining_expr = mkApps f remaining_args
443 fvs_remaining = exprFreeVars remaining_expr
444 (remaining_args, last_args) = splitAt n_remaining args
445 n_remaining = length args - length bndrs
447 ok bndr (Var arg) = bndr == arg
448 ok bndr other = False
450 -- we can't eta reduce something which must be saturated.
451 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
452 ok_to_eta_reduce _ = False --safe. ToDo: generalise
454 tryEta bndrs (Let bind@(NonRec b r) body)
455 | not (any (`elemVarSet` fvs) bndrs)
456 = case tryEta bndrs body of
457 Just e -> Just (Let bind e)
462 tryEta bndrs _ = Nothing
466 -- -----------------------------------------------------------------------------
467 -- Do the seq and par transformation
468 -- -----------------------------------------------------------------------------
470 Here we do two pre-codegen transformations:
476 case a of { DEFAULT -> rhs }
486 NB: seq# :: a -> Int# -- Evaluate value and return anything
487 par# :: a -> Int# -- Spark value and return anything
489 These transformations can't be done earlier, or else we might
490 think that the expression was strict in the variables in which
491 rhs is strict --- but that would defeat the purpose of seq and par.
495 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
496 -- DEFAULT alt is always first
497 = case isPrimOpId_maybe fn of
498 Just ParOp -> Case scrut bndr [deflt_alt]
499 Just SeqOp -> Case arg new_bndr [deflt_alt]
500 other -> Case scrut bndr alts
502 -- The binder shouldn't be used in the expression!
503 new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
504 setIdType bndr (exprType arg)
505 -- NB: SeqOp :: forall a. a -> Int#
506 -- So bndr has type Int#
507 -- But now we are going to scrutinise the SeqOp's argument directly,
508 -- so we must change the type of the case binder to match that
509 -- of the argument expression e.
511 mkCase scrut bndr alts = Case scrut bndr alts
515 -- -----------------------------------------------------------------------------
517 -- -----------------------------------------------------------------------------
521 = RhsDemand { isStrict :: Bool, -- True => used at least once
522 isOnceDem :: Bool -- True => used at most once
525 mkDem :: Demand -> Bool -> RhsDemand
526 mkDem strict once = RhsDemand (isStrictDmd strict) once
528 mkDemTy :: Demand -> Type -> RhsDemand
529 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
531 isOnceTy :: Type -> Bool
535 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
540 once | u `eqUsage` usOnce = True
541 | u `eqUsage` usMany = False
542 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
544 bdrDem :: Id -> RhsDemand
545 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
547 safeDem, onceDem :: RhsDemand
548 safeDem = RhsDemand False False -- always safe to use this
549 onceDem = RhsDemand False True -- used at most once
555 %************************************************************************
559 %************************************************************************
562 ------------------------------------------------------------------------------
564 -- ---------------------------------------------------------------------------
566 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
567 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
569 cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
571 | isId bndr && isLocalId bndr -- Top level things, which we don't want
572 -- to clone, have become ConstantIds by now
573 = getUniqueUs `thenUs` \ uniq ->
575 bndr' = setVarUnique bndr uniq
577 returnUs (extendVarEnv env bndr bndr', bndr')
579 | otherwise = returnUs (env, bndr)
581 ------------------------------------------------------------------------------
582 -- Cloning ccall Ids; each must have a unique name,
583 -- to give the code generator a handle to hang it on
584 -- ---------------------------------------------------------------------------
586 fiddleCCall :: Id -> UniqSM Id
588 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
589 returnUs (id `setVarUnique` uniq)
590 | otherwise = returnUs id
592 ------------------------------------------------------------------------------
593 -- Generating new binders
594 -- ---------------------------------------------------------------------------
596 newVar :: Type -> UniqSM Id
598 = getUniqueUs `thenUs` \ uniq ->
600 returnUs (mkSysLocal SLIT("sat") uniq ty)