2 % (c) The University of Glasgow, 1994-2000
4 \section{Core pass to saturate constructors and PrimOps}
8 coreSatPgm, coreSatExpr
11 #include "HsVersions.h"
19 import Var ( TyVar, setTyVarUnique )
31 -- ---------------------------------------------------------------------------
33 -- ---------------------------------------------------------------------------
35 Most of the contents of this pass used to be in CoreToStg. The
36 primary goals here are:
38 1. Get the program into "A-normal form". In particular:
40 f E ==> let x = E in f x
41 OR ==> case E of x -> f x
44 if E is a non-trivial expression.
45 Which transformation is used depends on whether f is strict or not.
46 [Previously the transformation to case used to be done by the
47 simplifier, but it's better done here. It does mean that f needs
48 to have its strictness info correct!.]
50 2. Similarly, convert any unboxed lets into cases.
51 [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
52 right up to this point.]
54 This is all done modulo type applications and abstractions, so that
55 when type erasure is done for conversion to STG, we don't end up with
56 any trivial or useless bindings.
58 3. Ensure that lambdas only occur as the RHS of a binding
59 (The code generator can't deal with anything else.)
61 4. Saturate constructor and primop applications.
65 -- -----------------------------------------------------------------------------
67 -- -----------------------------------------------------------------------------
70 coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
71 coreSatPgm dflags binds
72 = do showPass dflags "CoreSat"
73 us <- mkSplitUniqSupply 's'
74 let new_binds = initUs_ us (coreSatBinds binds)
75 endPass dflags "CoreSat" Opt_D_dump_sat new_binds
77 coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr
78 coreSatExpr dflags expr
79 = do showPass dflags "CoreSat"
80 us <- mkSplitUniqSupply 's'
81 let new_expr = initUs_ us (coreSatAnExpr expr)
82 dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:"
86 -- ---------------------------------------------------------------------------
87 -- Dealing with bindings
88 -- ---------------------------------------------------------------------------
91 = RecF [(Id, CoreExpr)]
93 CoreExpr -- *Can* be a Lam
97 coreSatBinds :: [CoreBind] -> UniqSM [CoreBind]
98 coreSatBinds [] = returnUs []
100 = coreSatBind b `thenUs` \ float ->
101 coreSatBinds bs `thenUs` \ new_bs ->
103 NonRecF bndr rhs dem floats
104 -> ASSERT2( not (isStrictDem dem) &&
105 not (isUnLiftedType (idType bndr)),
106 ppr b ) -- No top-level cases!
108 mkBinds floats rhs `thenUs` \ new_rhs ->
109 returnUs (NonRec bndr new_rhs : new_bs)
110 -- Keep all the floats inside...
111 -- Some might be cases etc
112 -- We might want to revisit this decision
114 RecF prs -> returnUs (Rec prs : new_bs)
116 coreSatBind :: CoreBind -> UniqSM FloatingBind
117 coreSatBind (NonRec binder rhs)
118 = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
119 returnUs (NonRecF binder new_rhs (bdrDem binder) floats)
120 coreSatBind (Rec pairs)
121 = mapUs do_rhs pairs `thenUs` \ new_rhss ->
122 returnUs (RecF (binders `zip` new_rhss))
124 binders = map fst pairs
126 coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
127 mkBinds floats new_rhs `thenUs` \ new_rhs' ->
128 -- NB: new_rhs' might still be a Lam (and we want that)
131 -- ---------------------------------------------------------------------------
132 -- Making arguments atomic (function args & constructor args)
133 -- ---------------------------------------------------------------------------
135 -- This is where we arrange that a non-trivial argument is let-bound
136 coreSatArg :: CoreArg -> RhsDemand -> UniqSM ([FloatingBind], CoreArg)
138 = coreSatExprFloat arg `thenUs` \ (floats, arg') ->
139 if exprIsTrivial arg'
140 then returnUs (floats, arg')
141 else newVar (exprType arg') `thenUs` \ v ->
142 returnUs ([NonRecF v arg' dem floats], Var v)
144 -- ---------------------------------------------------------------------------
145 -- Dealing with expressions
146 -- ---------------------------------------------------------------------------
148 coreSatAnExpr :: CoreExpr -> UniqSM CoreExpr
150 = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
154 coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr)
158 -- e = let bs in e' (semantically, that is!)
161 -- f (g x) ===> ([v = g x], f v)
163 coreSatExprFloat (Var v)
164 = fiddleCCall v `thenUs` \ v ->
165 maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
168 coreSatExprFloat (Lit lit)
169 = returnUs ([], Lit lit)
171 coreSatExprFloat (Let bind body)
172 = coreSatBind bind `thenUs` \ new_bind ->
173 coreSatExprFloat body `thenUs` \ (floats, new_body) ->
174 returnUs (new_bind:floats, new_body)
176 coreSatExprFloat (Note other_note expr)
177 = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
178 returnUs (floats, Note other_note expr)
180 coreSatExprFloat expr@(Type _)
181 = returnUs ([], expr)
183 coreSatExprFloat (Lam v e)
184 = coreSatAnExpr e `thenUs` \ e' ->
185 returnUs ([], Lam v e')
187 coreSatExprFloat (Case scrut bndr alts)
188 = coreSatExprFloat scrut `thenUs` \ (floats, scrut) ->
189 mapUs sat_alt alts `thenUs` \ alts ->
190 returnUs (floats, Case scrut bndr alts)
192 sat_alt (con, bs, rhs)
193 = coreSatAnExpr rhs `thenUs` \ rhs ->
194 deLam rhs `thenUs` \ rhs ->
195 returnUs (con, bs, rhs)
197 coreSatExprFloat expr@(App _ _)
198 = collect_args expr 0 `thenUs` \ (app,(head,depth),ty,floats,ss) ->
199 ASSERT(null ss) -- make sure we used all the strictness info
201 -- Now deal with the function
203 Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
204 returnUs (floats, app')
206 _other -> returnUs (floats, app)
210 -- Deconstruct and rebuild the application, floating any non-atomic
211 -- arguments to the outside. We collect the type of the expression,
212 -- the head of the applicaiton, and the number of actual value arguments,
213 -- all of which are used to possibly saturate this application if it
214 -- has a constructor or primop at the head.
218 -> Int -- current app depth
219 -> UniqSM (CoreExpr, -- the rebuilt expression
220 (CoreExpr,Int), -- the head of the application,
221 -- and no. of args it was applied to
222 Type, -- type of the whole expr
223 [FloatingBind], -- any floats we pulled out
224 [Demand]) -- remaining argument demands
226 collect_args (App fun arg@(Type arg_ty)) depth
227 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
228 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
230 collect_args (App fun arg) depth
231 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
233 (ss1, ss_rest) = case ss of
234 (ss1:ss_rest) -> (ss1, ss_rest)
236 (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $
237 splitFunTy_maybe fun_ty
239 coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
240 returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest)
242 collect_args (Var v) depth
243 = fiddleCCall v `thenUs` \ v ->
244 returnUs (Var v, (Var v, depth), idType v, [], stricts)
246 stricts = case idStrictness v of
247 StrictnessInfo demands _
248 | depth >= length demands -> demands
251 -- If depth < length demands, then we have too few args to
252 -- satisfy strictness info so we have to ignore all the
253 -- strictness info, e.g. + (error "urk")
254 -- Here, we can't evaluate the arg strictly, because this
255 -- partial application might be seq'd
257 collect_args (Note (Coerce ty1 ty2) fun) depth
258 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
259 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
261 collect_args (Note note fun) depth
263 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
264 returnUs (Note note fun', hd, fun_ty, floats, ss)
266 -- non-variable fun, better let-bind it
267 collect_args fun depth
268 = newVar ty `thenUs` \ fn_id ->
269 coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
270 returnUs (Var fn_id, (Var fn_id, depth), ty,
271 [NonRecF fn_id fun onceDem fun_floats], [])
272 where ty = exprType fun
274 ignore_note InlineCall = True
275 ignore_note InlineMe = True
276 ignore_note _other = False
277 -- we don't ignore SCCs, since they require some code generation
279 ------------------------------------------------------------------------------
280 -- Generating new binders
281 -- ---------------------------------------------------------------------------
283 newVar :: Type -> UniqSM Id
285 = getUniqueUs `thenUs` \ uniq ->
287 returnUs (mkSysLocal SLIT("sat") uniq ty)
289 cloneTyVar :: TyVar -> UniqSM TyVar
291 = getUniqueUs `thenUs` \ uniq ->
292 returnUs (setTyVarUnique tv uniq)
294 ------------------------------------------------------------------------------
295 -- Building the saturated syntax
296 -- ---------------------------------------------------------------------------
298 -- maybeSaturate deals with saturating primops and constructors
299 -- The type is the type of the entire application
300 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
301 maybeSaturate fn expr n_args ty
302 = case idFlavour fn of
303 PrimOpId op -> saturate fn expr n_args ty
304 DataConId dc -> saturate fn expr n_args ty
305 other -> returnUs expr
307 saturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
308 -- The type should be the type of expr.
309 -- The returned expression should also have this type
310 saturate fn expr n_args ty
311 = go excess_arity expr ty
313 fn_arity = idArity fn
314 excess_arity = fn_arity - n_args
317 | n == 0 -- Saturated, so nothing to do
320 | otherwise -- An unsaturated constructor or primop; eta expand it
321 = case splitForAllTy_maybe ty of {
322 Just (tv,ty') -> go n (App expr (Type (mkTyVarTy tv))) ty' `thenUs` \ expr' ->
323 returnUs (Lam tv expr') ;
326 case splitFunTy_maybe ty of {
327 Just (arg_ty, res_ty)
328 -> newVar arg_ty `thenUs` \ arg' ->
329 go (n-1) (App expr (Var arg')) res_ty `thenUs` \ expr' ->
330 returnUs (Lam arg' expr') ;
333 case splitNewType_maybe ty of {
334 Just ty' -> go n (mkCoerce ty' ty expr) ty' `thenUs` \ expr' ->
335 returnUs (mkCoerce ty ty' expr') ;
337 Nothing -> pprTrace "Bad saturate" ((ppr fn <+> ppr expr) $$ ppr ty)
343 = case idFlavour id of
344 PrimOpId (CCallOp ccall) ->
345 -- Make a guaranteed unique name for a dynamic ccall.
346 getUniqueUs `thenUs` \ uniq ->
347 returnUs (modifyIdInfo (`setFlavourInfo`
348 PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
352 -- ---------------------------------------------------------------------------
353 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
354 -- ---------------------------------------------------------------------------
357 = deLam e `thenUs` \ e ->
360 -- types will all disappear, so that's ok
361 deLam (Lam x e) | isTyVar x
362 = deLam e `thenUs` \ e ->
366 -- Try for eta reduction
370 -- Eta failed, so let-bind the lambda
372 = newVar (exprType expr) `thenUs` \ fn ->
373 returnUs (Let (NonRec fn expr) (Var fn))
376 (bndrs, body) = collectBinders expr
379 | n_remaining >= 0 &&
380 and (zipWith ok bndrs last_args) &&
381 not (any (`elemVarSet` fvs_remaining) bndrs)
382 = Just remaining_expr
384 (f, args) = collectArgs expr
385 remaining_expr = mkApps f remaining_args
386 fvs_remaining = exprFreeVars remaining_expr
387 (remaining_args, last_args) = splitAt n_remaining args
388 n_remaining = length args - length bndrs
390 ok bndr (Var arg) = bndr == arg
391 ok bndr other = False
393 eta (Let bind@(NonRec b r) body)
394 | not (any (`elemVarSet` fvs) bndrs)
396 Just e -> Just (Let bind e)
398 where fvs = exprFreeVars r
402 deLam expr = returnUs expr
404 -- ---------------------------------------------------------------------------
405 -- Precipitating the floating bindings
406 -- ---------------------------------------------------------------------------
408 mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr
409 mkBinds [] body = returnUs body
411 = deLam body `thenUs` \ body' ->
414 go [] body = returnUs body
415 go (b:bs) body = go bs body `thenUs` \ body' ->
419 mkBind (RecF prs) body = returnUs (Let (Rec prs) body)
421 mkBind (NonRecF bndr rhs dem floats) body
423 -- We shouldn't get let or case of the form v=w
424 = if exprIsTrivial rhs
425 then pprTrace "mkBind" (ppr bndr <+> ppr rhs)
426 (mk_let bndr rhs dem floats body)
427 else mk_let bndr rhs dem floats body
429 mk_let bndr rhs dem floats body
431 | isUnLiftedType bndr_rep_ty
432 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
433 mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
437 -- Strict let with WHNF rhs
439 Let (NonRec bndr rhs) body
441 -- Lazy let with WHNF rhs; float until we find a strict binding
443 (floats_out, floats_in) = splitFloats floats
445 mkBinds floats_in rhs `thenUs` \ new_rhs ->
447 Let (NonRec bndr new_rhs) body
449 | otherwise -- Not WHNF
451 -- Strict let with non-WHNF rhs
452 mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
454 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
455 mkBinds floats rhs `thenUs` \ new_rhs ->
456 returnUs (Let (NonRec bndr new_rhs) body)
459 bndr_rep_ty = repType (idType bndr)
460 is_strict = isStrictDem dem
461 is_whnf = exprIsValue rhs
463 splitFloats fs@(NonRecF _ _ dem _ : _)
464 | isStrictDem dem = ([], fs)
466 splitFloats (f : fs) = case splitFloats fs of
467 (fs_out, fs_in) -> (f : fs_out, fs_in)
469 splitFloats [] = ([], [])
471 -- -----------------------------------------------------------------------------
473 -- -----------------------------------------------------------------------------
476 = RhsDemand { isStrictDem :: Bool, -- True => used at least once
477 isOnceDem :: Bool -- True => used at most once
480 mkDem :: Demand -> Bool -> RhsDemand
481 mkDem strict once = RhsDemand (isStrict strict) once
483 mkDemTy :: Demand -> Type -> RhsDemand
484 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
486 isOnceTy :: Type -> Bool
490 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
495 once | u == usOnce = True
496 | u == usMany = False
497 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
499 bdrDem :: Id -> RhsDemand
500 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
502 safeDem, onceDem :: RhsDemand
503 safeDem = RhsDemand False False -- always safe to use this
504 onceDem = RhsDemand False True -- used at most once