2 % (c) The University of Glasgow, 1994-2000
4 \section{Core pass to saturate constructors and PrimOps}
8 coreSatPgm, coreSatExpr
11 #include "HsVersions.h"
13 import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand, exprArity )
14 import CoreFVs ( exprFreeVars )
15 import CoreLint ( endPass )
17 import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
18 isUnLiftedType, isUnboxedTupleType, repType,
19 uaUTy, usOnce, usMany, seqType )
20 import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
21 import PrimOp ( PrimOp(..) )
22 import Var ( Id, TyVar, setTyVarUnique )
24 import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity,
25 isDeadBinder, setIdType, isPrimOpId_maybe, hasNoBinding
36 -- ---------------------------------------------------------------------------
38 -- ---------------------------------------------------------------------------
41 By the time this pass happens, we have spat out tidied Core into
42 the interface file, including all IdInfo.
44 So we must not change the arity of any top-level function,
45 because we've already fixed it and put it out into the interface file.
46 Nor must we change a value (e.g. constructor) into a thunk.
48 It's ok to introduce extra bindings, which don't appear in the
49 interface file. We don't put arity info on these extra bindings,
50 because they are never fully applied, so there's no chance of
51 compiling just-a-fast-entry point for them.
53 Most of the contents of this pass used to be in CoreToStg. The
54 primary goals here are:
56 1. Saturate constructor and primop applications.
58 2. Convert to A-normal form:
60 * Use case for strict arguments:
61 f E ==> case E of x -> f x
64 * Use let for non-trivial lazy arguments
65 f E ==> let x = E in f x
66 (were f is lazy and x is non-trivial)
68 3. Similarly, convert any unboxed lets into cases.
69 [I'm experimenting with leaving 'ok-for-speculation'
70 rhss in let-form right up to this point.]
72 4. Ensure that lambdas only occur as the RHS of a binding
73 (The code generator can't deal with anything else.)
75 5. Do the seq/par munging. See notes with mkCase below.
77 This is all done modulo type applications and abstractions, so that
78 when type erasure is done for conversion to STG, we don't end up with
79 any trivial or useless bindings.
83 -- -----------------------------------------------------------------------------
85 -- -----------------------------------------------------------------------------
88 coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
89 coreSatPgm dflags binds
90 = do showPass dflags "CoreSat"
91 us <- mkSplitUniqSupply 's'
92 let new_binds = initUs_ us (coreSatTopBinds binds)
93 endPass dflags "CoreSat" Opt_D_dump_sat new_binds
95 coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr
96 coreSatExpr dflags expr
97 = do showPass dflags "CoreSat"
98 us <- mkSplitUniqSupply 's'
99 let new_expr = initUs_ us (coreSatAnExpr expr)
100 dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:"
104 -- ---------------------------------------------------------------------------
105 -- Dealing with bindings
106 -- ---------------------------------------------------------------------------
108 data FloatingBind = FloatLet CoreBind
109 | FloatCase Id CoreExpr
111 allLazy :: OrdList FloatingBind -> Bool
112 allLazy floats = foldOL check True floats
114 check (FloatLet _) y = y
115 check (FloatCase _ _) y = False
117 coreSatTopBinds :: [CoreBind] -> UniqSM [CoreBind]
118 -- Very careful to preserve the arity of top-level functions
119 coreSatTopBinds [] = returnUs []
121 coreSatTopBinds (NonRec b r : binds)
122 = coreSatTopRhs b r `thenUs` \ (floats, r') ->
123 coreSatTopBinds binds `thenUs` \ binds' ->
124 returnUs (floats ++ NonRec b r' : binds')
126 coreSatTopBinds (Rec prs : binds)
127 = mapAndUnzipUs do_pair prs `thenUs` \ (floats_s, prs') ->
128 coreSatTopBinds binds `thenUs` \ binds' ->
129 returnUs (Rec (flattenBinds (concat floats_s) ++ prs') : binds')
131 do_pair (b,r) = coreSatTopRhs b r `thenUs` \ (floats, r') ->
132 returnUs (floats, (b, r'))
134 coreSatTopRhs :: Id -> CoreExpr -> UniqSM ([CoreBind], CoreExpr)
135 -- The trick here is that if we see
136 -- x = $wC p $wJust q
137 -- we want to transform to
138 -- sat = \a -> $wJust a
141 -- x = let sat = \a -> $wJust a in $wC p sat q
143 -- The latter is bad because the thing was a value before, but
144 -- is a thunk now, and that's wrong because now x may need to
145 -- be in other bindings' SRTs.
146 -- This has to be right for recursive as well as non-recursive bindings
148 -- Notice that it's right to give sat vanilla IdInfo; in particular NoCafRefs
150 -- You might worry that arity might increase, thus
151 -- x = $wC a ==> x = \ b c -> $wC a b c
152 -- but the simpifier does eta expansion vigorously, so I don't think this
153 -- can occur. If it did, it would be a problem, because x's arity changes,
154 -- so we have an ASSERT to check. (I use WARN so we can see the output.)
157 = coreSatExprFloat rhs `thenUs` \ (floats, rhs1) ->
158 if exprIsValue rhs then
159 ASSERT( allLazy floats )
160 WARN( idArity b /= exprArity rhs1, ptext SLIT("Disaster!") <+> ppr b )
161 returnUs ([bind | FloatLet bind <- fromOL floats], rhs1)
163 mkBinds floats rhs1 `thenUs` \ rhs2 ->
164 WARN( idArity b /= exprArity rhs2, ptext SLIT("Disaster!") <+> ppr b )
168 coreSatBind :: CoreBind -> UniqSM (OrdList FloatingBind)
169 -- Used for non-top-level bindings
170 -- We return a *list* of bindings because we may start with
172 -- where x is demanded, in which case we want to finish with
175 -- And then x will actually end up case-bound
177 coreSatBind (NonRec binder rhs)
178 = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
179 mkNonRec binder (bdrDem binder) floats new_rhs
180 -- NB: if there are any lambdas at the top of the RHS,
181 -- the floats will be empty, so the arity won't be affected
183 coreSatBind (Rec pairs)
184 -- Don't bother to try to float bindings out of RHSs
185 -- (compare mkNonRec, which does try)
186 = mapUs do_rhs pairs `thenUs` \ new_pairs ->
187 returnUs (unitOL (FloatLet (Rec new_pairs)))
189 do_rhs (bndr,rhs) = coreSatAnExpr rhs `thenUs` \ new_rhs' ->
190 returnUs (bndr,new_rhs')
193 -- ---------------------------------------------------------------------------
194 -- Making arguments atomic (function args & constructor args)
195 -- ---------------------------------------------------------------------------
197 -- This is where we arrange that a non-trivial argument is let-bound
198 coreSatArg :: CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg)
200 = coreSatExprFloat arg `thenUs` \ (floats, arg') ->
201 if needs_binding arg'
202 then returnUs (floats, arg')
203 else newVar (exprType arg') `thenUs` \ v ->
204 mkNonRec v dem floats arg' `thenUs` \ floats' ->
205 returnUs (floats', Var v)
207 needs_binding | opt_KeepStgTypes = exprIsAtom
208 | otherwise = exprIsTrivial
210 -- ---------------------------------------------------------------------------
211 -- Dealing with expressions
212 -- ---------------------------------------------------------------------------
214 coreSatAnExpr :: CoreExpr -> UniqSM CoreExpr
216 = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
220 coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
224 -- e = let bs in e' (semantically, that is!)
227 -- f (g x) ===> ([v = g x], f v)
229 coreSatExprFloat (Var v)
230 = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
231 returnUs (nilOL, app)
233 coreSatExprFloat (Lit lit)
234 = returnUs (nilOL, Lit lit)
236 coreSatExprFloat (Let bind body)
237 = coreSatBind bind `thenUs` \ new_binds ->
238 coreSatExprFloat body `thenUs` \ (floats, new_body) ->
239 returnUs (new_binds `appOL` floats, new_body)
241 coreSatExprFloat (Note n@(SCC _) expr)
242 = coreSatAnExpr expr `thenUs` \ expr ->
243 deLam expr `thenUs` \ expr ->
244 returnUs (nilOL, Note n expr)
246 coreSatExprFloat (Note other_note expr)
247 = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
248 returnUs (floats, Note other_note expr)
250 coreSatExprFloat expr@(Type _)
251 = returnUs (nilOL, expr)
253 coreSatExprFloat expr@(Lam _ _)
254 = coreSatAnExpr body `thenUs` \ body' ->
255 returnUs (nilOL, mkLams bndrs body')
257 (bndrs,body) = collectBinders expr
259 coreSatExprFloat (Case scrut bndr alts)
260 = coreSatExprFloat scrut `thenUs` \ (floats, scrut) ->
261 mapUs sat_alt alts `thenUs` \ alts ->
262 returnUs (floats, mkCase scrut bndr alts)
264 sat_alt (con, bs, rhs)
265 = coreSatAnExpr rhs `thenUs` \ rhs ->
266 deLam rhs `thenUs` \ rhs ->
267 returnUs (con, bs, rhs)
269 coreSatExprFloat expr@(App _ _)
270 = collect_args expr 0 `thenUs` \ (app,(head,depth),ty,floats,ss) ->
271 ASSERT(null ss) -- make sure we used all the strictness info
273 -- Now deal with the function
275 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
276 returnUs (floats, app')
278 _other -> returnUs (floats, app)
282 -- Deconstruct and rebuild the application, floating any non-atomic
283 -- arguments to the outside. We collect the type of the expression,
284 -- the head of the application, and the number of actual value arguments,
285 -- all of which are used to possibly saturate this application if it
286 -- has a constructor or primop at the head.
290 -> Int -- current app depth
291 -> UniqSM (CoreExpr, -- the rebuilt expression
292 (CoreExpr,Int), -- the head of the application,
293 -- and no. of args it was applied to
294 Type, -- type of the whole expr
295 OrdList FloatingBind, -- any floats we pulled out
296 [Demand]) -- remaining argument demands
298 collect_args (App fun arg@(Type arg_ty)) depth
299 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
300 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
302 collect_args (App fun arg) depth
303 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
305 (ss1, ss_rest) = case ss of
306 (ss1:ss_rest) -> (ss1, ss_rest)
308 (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $
309 splitFunTy_maybe fun_ty
311 coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
312 returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
314 collect_args (Var v) depth
315 = returnUs (Var v, (Var v, depth), idType v, nilOL, stricts)
317 stricts = case idStrictness v of
318 StrictnessInfo demands _
319 | depth >= length demands -> demands
322 -- If depth < length demands, then we have too few args to
323 -- satisfy strictness info so we have to ignore all the
324 -- strictness info, e.g. + (error "urk")
325 -- Here, we can't evaluate the arg strictly, because this
326 -- partial application might be seq'd
328 collect_args (Note (Coerce ty1 ty2) fun) depth
329 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
330 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
332 collect_args (Note note fun) depth
334 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
335 returnUs (Note note fun', hd, fun_ty, floats, ss)
337 -- non-variable fun, better let-bind it
338 collect_args fun depth
339 = coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
340 newVar ty `thenUs` \ fn_id ->
341 mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
342 returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
346 ignore_note InlineCall = True
347 ignore_note InlineMe = True
348 ignore_note _other = False
349 -- we don't ignore SCCs, since they require some code generation
351 ------------------------------------------------------------------------------
352 -- Generating new binders
353 -- ---------------------------------------------------------------------------
355 newVar :: Type -> UniqSM Id
357 = getUniqueUs `thenUs` \ uniq ->
359 returnUs (mkSysLocal SLIT("sat") uniq ty)
361 cloneTyVar :: TyVar -> UniqSM TyVar
363 = getUniqueUs `thenUs` \ uniq ->
364 returnUs (setTyVarUnique tv uniq)
366 ------------------------------------------------------------------------------
367 -- Building the saturated syntax
368 -- ---------------------------------------------------------------------------
370 -- maybeSaturate deals with saturating primops and constructors
371 -- The type is the type of the entire application
372 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
373 maybeSaturate fn expr n_args ty
374 | hasNoBinding fn = saturate_it
375 | otherwise = returnUs expr
377 fn_arity = idArity fn
378 excess_arity = fn_arity - n_args
379 saturate_it = getUs `thenUs` \ us ->
380 returnUs (etaExpand excess_arity us expr ty)
382 -- ---------------------------------------------------------------------------
383 -- Precipitating the floating bindings
384 -- ---------------------------------------------------------------------------
386 -- mkNonRec is used for local bindings only, not top level
387 mkNonRec :: Id -> RhsDemand -- Lhs: id with demand
388 -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
389 -> UniqSM (OrdList FloatingBind)
390 mkNonRec bndr dem floats rhs
391 | exprIsValue rhs && allLazy floats -- Notably constructor applications
392 = -- Why the test for allLazy? You might think that the only
393 -- floats we can get out of a value are eta expansions
394 -- e.g. C $wJust ==> let s = \x -> $wJust x in C s
395 -- Here we want to float the s binding.
397 -- But if the programmer writes this:
398 -- f x = case x of { (a,b) -> \y -> a }
399 -- then the strictness analyser may say that f has strictness "S"
400 -- Later the eta expander will transform to
401 -- f x y = case x of { (a,b) -> a }
402 -- So now f has arity 2. Now CoreSat may see
404 -- so the E argument will turn into a FloatCase.
405 -- Indeed we should end up with
406 -- v = case E of { r -> f r }
407 -- That is, we should not float, even though (f r) is a value
408 returnUs (floats `snocOL` FloatLet (NonRec bndr rhs))
410 | isUnLiftedType bndr_rep_ty || isStrictDem dem
411 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
412 returnUs (floats `snocOL` FloatCase bndr rhs)
415 = mkBinds floats rhs `thenUs` \ rhs' ->
416 returnUs (unitOL (FloatLet (NonRec bndr rhs')))
419 bndr_rep_ty = repType (idType bndr)
421 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
423 | isNilOL binds = returnUs body
424 | otherwise = deLam body `thenUs` \ body' ->
425 returnUs (foldOL mk_bind body' binds)
427 mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
428 mk_bind (FloatLet bind) body = Let bind body
430 -- ---------------------------------------------------------------------------
431 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
432 -- We arrange that they only show up as the RHS of a let(rec)
433 -- ---------------------------------------------------------------------------
435 deLam :: CoreExpr -> UniqSM CoreExpr
436 -- Remove top level lambdas by let-bindinig
439 = -- You can get things like
440 -- case e of { p -> coerce t (\s -> ...) }
441 deLam expr `thenUs` \ expr' ->
442 returnUs (Note n expr')
445 | null bndrs = returnUs expr
446 | otherwise = case tryEta bndrs body of
447 Just no_lam_result -> returnUs no_lam_result
448 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
449 returnUs (Let (NonRec fn expr) (Var fn))
451 (bndrs,body) = collectBinders expr
453 -- Why try eta reduction? Hasn't the simplifier already done eta?
454 -- But the simplifier only eta reduces if that leaves something
455 -- trivial (like f, or f Int). But for deLam it would be enough to
456 -- get to a partial application, like (map f).
458 tryEta bndrs expr@(App _ _)
459 | ok_to_eta_reduce f &&
461 and (zipWith ok bndrs last_args) &&
462 not (any (`elemVarSet` fvs_remaining) bndrs)
463 = Just remaining_expr
465 (f, args) = collectArgs expr
466 remaining_expr = mkApps f remaining_args
467 fvs_remaining = exprFreeVars remaining_expr
468 (remaining_args, last_args) = splitAt n_remaining args
469 n_remaining = length args - length bndrs
471 ok bndr (Var arg) = bndr == arg
472 ok bndr other = False
474 -- we can't eta reduce something which must be saturated.
475 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
476 ok_to_eta_reduce _ = False --safe. ToDo: generalise
478 tryEta bndrs (Let bind@(NonRec b r) body)
479 | not (any (`elemVarSet` fvs) bndrs)
480 = case tryEta bndrs body of
481 Just e -> Just (Let bind e)
486 tryEta bndrs _ = Nothing
490 -- -----------------------------------------------------------------------------
491 -- Do the seq and par transformation
492 -- -----------------------------------------------------------------------------
494 Here we do two pre-codegen transformations:
500 case a of { DEFAULT -> rhs }
510 NB: seq# :: a -> Int# -- Evaluate value and return anything
511 par# :: a -> Int# -- Spark value and return anything
513 These transformations can't be done earlier, or else we might
514 think that the expression was strict in the variables in which
515 rhs is strict --- but that would defeat the purpose of seq and par.
519 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts
520 = case isPrimOpId_maybe fn of
521 Just ParOp -> Case scrut bndr [deflt_alt]
523 Case arg new_bndr [deflt_alt]
524 other -> Case scrut bndr alts
526 (deflt_alt@(_,_,rhs) : _) = [alt | alt@(DEFAULT,_,_) <- alts]
528 -- The binder shouldn't be used in the expression!
529 new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
530 setIdType bndr (exprType arg)
531 -- NB: SeqOp :: forall a. a -> Int#
532 -- So bndr has type Int#
533 -- But now we are going to scrutinise the SeqOp's argument directly,
534 -- so we must change the type of the case binder to match that
535 -- of the argument expression e.
537 mkCase scrut bndr alts = Case scrut bndr alts
541 -- -----------------------------------------------------------------------------
543 -- -----------------------------------------------------------------------------
547 = RhsDemand { isStrictDem :: Bool, -- True => used at least once
548 isOnceDem :: Bool -- True => used at most once
551 mkDem :: Demand -> Bool -> RhsDemand
552 mkDem strict once = RhsDemand (isStrict strict) once
554 mkDemTy :: Demand -> Type -> RhsDemand
555 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
557 isOnceTy :: Type -> Bool
561 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
566 once | u == usOnce = True
567 | u == usMany = False
568 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
570 bdrDem :: Id -> RhsDemand
571 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
573 safeDem, onceDem :: RhsDemand
574 safeDem = RhsDemand False False -- always safe to use this
575 onceDem = RhsDemand False True -- used at most once