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 )
32 -- ---------------------------------------------------------------------------
34 -- ---------------------------------------------------------------------------
36 Most of the contents of this pass used to be in CoreToStg. The
37 primary goals here are:
39 1. Get the program into "A-normal form". In particular:
41 f E ==> let x = E in f x
42 OR ==> case E of x -> f x
45 if E is a non-trivial expression.
46 Which transformation is used depends on whether f is strict or not.
47 [Previously the transformation to case used to be done by the
48 simplifier, but it's better done here. It does mean that f needs
49 to have its strictness info correct!.]
51 2. Similarly, convert any unboxed lets into cases.
52 [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
53 right up to this point.]
55 This is all done modulo type applications and abstractions, so that
56 when type erasure is done for conversion to STG, we don't end up with
57 any trivial or useless bindings.
59 3. Ensure that lambdas only occur as the RHS of a binding
60 (The code generator can't deal with anything else.)
62 4. Saturate constructor and primop applications.
66 -- -----------------------------------------------------------------------------
68 -- -----------------------------------------------------------------------------
71 coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
72 coreSatPgm dflags binds
73 = do showPass dflags "CoreSat"
74 us <- mkSplitUniqSupply 's'
75 let new_binds = initUs_ us (coreSatBinds binds)
76 endPass dflags "CoreSat" Opt_D_dump_sat new_binds
78 coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr
79 coreSatExpr dflags expr
80 = do showPass dflags "CoreSat"
81 us <- mkSplitUniqSupply 's'
82 let new_expr = initUs_ us (coreSatAnExpr expr)
83 dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:"
87 -- ---------------------------------------------------------------------------
88 -- Dealing with bindings
89 -- ---------------------------------------------------------------------------
92 = RecF [(Id, CoreExpr)]
94 CoreExpr -- *Can* be a Lam
98 coreSatBinds :: [CoreBind] -> UniqSM [CoreBind]
99 coreSatBinds [] = returnUs []
101 = coreSatBind b `thenUs` \ float ->
102 coreSatBinds bs `thenUs` \ new_bs ->
104 NonRecF bndr rhs dem floats
105 -> ASSERT2( not (isStrictDem dem) &&
106 not (isUnLiftedType (idType bndr)),
107 ppr b ) -- No top-level cases!
109 mkBinds floats rhs `thenUs` \ new_rhs ->
110 returnUs (NonRec bndr new_rhs : new_bs)
111 -- Keep all the floats inside...
112 -- Some might be cases etc
113 -- We might want to revisit this decision
115 RecF prs -> returnUs (Rec prs : new_bs)
117 coreSatBind :: CoreBind -> UniqSM FloatingBind
118 coreSatBind (NonRec binder rhs)
119 = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
120 returnUs (NonRecF binder new_rhs (bdrDem binder) floats)
121 coreSatBind (Rec pairs)
122 = mapUs do_rhs pairs `thenUs` \ new_rhss ->
123 returnUs (RecF (binders `zip` new_rhss))
125 binders = map fst pairs
127 coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
128 mkBinds floats new_rhs `thenUs` \ new_rhs' ->
129 -- NB: new_rhs' might still be a Lam (and we want that)
132 -- ---------------------------------------------------------------------------
133 -- Making arguments atomic (function args & constructor args)
134 -- ---------------------------------------------------------------------------
136 -- This is where we arrange that a non-trivial argument is let-bound
137 coreSatArg :: CoreArg -> RhsDemand -> UniqSM ([FloatingBind], CoreArg)
139 = coreSatExprFloat arg `thenUs` \ (floats, arg') ->
140 if exprIsTrivial arg'
141 then returnUs (floats, arg')
142 else newVar (exprType arg') `thenUs` \ v ->
143 returnUs ([NonRecF v arg' dem floats], Var v)
145 -- ---------------------------------------------------------------------------
146 -- Dealing with expressions
147 -- ---------------------------------------------------------------------------
149 coreSatAnExpr :: CoreExpr -> UniqSM CoreExpr
151 = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
155 coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr)
159 -- e = let bs in e' (semantically, that is!)
162 -- f (g x) ===> ([v = g x], f v)
164 coreSatExprFloat (Var 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 = returnUs (Var v, (Var v, depth), idType v, [], stricts)
245 stricts = case idStrictness v of
246 StrictnessInfo demands _
247 | depth >= length demands -> demands
250 -- If depth < length demands, then we have too few args to
251 -- satisfy strictness info so we have to ignore all the
252 -- strictness info, e.g. + (error "urk")
253 -- Here, we can't evaluate the arg strictly, because this
254 -- partial application might be seq'd
256 collect_args (Note (Coerce ty1 ty2) fun) depth
257 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
258 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
260 collect_args (Note note fun) depth
262 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
263 returnUs (Note note fun', hd, fun_ty, floats, ss)
265 -- non-variable fun, better let-bind it
266 collect_args fun depth
267 = newVar ty `thenUs` \ fn_id ->
268 coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
269 returnUs (Var fn_id, (Var fn_id, depth), ty,
270 [NonRecF fn_id fun onceDem fun_floats], [])
271 where ty = exprType fun
273 ignore_note InlineCall = True
274 ignore_note InlineMe = True
275 ignore_note _other = False
276 -- we don't ignore SCCs, since they require some code generation
278 ------------------------------------------------------------------------------
279 -- Generating new binders
280 -- ---------------------------------------------------------------------------
282 newVar :: Type -> UniqSM Id
284 = getUniqueUs `thenUs` \ uniq ->
286 returnUs (mkSysLocal SLIT("sat") uniq ty)
288 cloneTyVar :: TyVar -> UniqSM TyVar
290 = getUniqueUs `thenUs` \ uniq ->
291 returnUs (setTyVarUnique tv uniq)
293 ------------------------------------------------------------------------------
294 -- Building the saturated syntax
295 -- ---------------------------------------------------------------------------
297 -- maybeSaturate deals with saturating primops and constructors
298 -- The type is the type of the entire application
299 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
300 maybeSaturate fn expr n_args ty
301 = case idFlavour fn of
302 PrimOpId op -> saturate_it
303 DataConId dc -> saturate_it
304 other -> returnUs expr
306 fn_arity = idArity fn
307 excess_arity = fn_arity - n_args
308 saturate_it = getUs `thenUs` \ us ->
309 returnUs (etaExpand excess_arity us expr ty)
311 -- ---------------------------------------------------------------------------
312 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
313 -- ---------------------------------------------------------------------------
316 = deLam e `thenUs` \ e ->
319 -- types will all disappear, so that's ok
320 deLam (Lam x e) | isTyVar x
321 = deLam e `thenUs` \ e ->
325 -- Try for eta reduction
329 -- Eta failed, so let-bind the lambda
331 = newVar (exprType expr) `thenUs` \ fn ->
332 returnUs (Let (NonRec fn expr) (Var fn))
335 (bndrs, body) = collectBinders expr
338 | ok_to_eta_reduce f &&
340 and (zipWith ok bndrs last_args) &&
341 not (any (`elemVarSet` fvs_remaining) bndrs)
342 = Just remaining_expr
344 (f, args) = collectArgs expr
345 remaining_expr = mkApps f remaining_args
346 fvs_remaining = exprFreeVars remaining_expr
347 (remaining_args, last_args) = splitAt n_remaining args
348 n_remaining = length args - length bndrs
350 ok bndr (Var arg) = bndr == arg
351 ok bndr other = False
353 -- we can't eta reduce something which must be saturated.
354 ok_to_eta_reduce (Var f)
355 = case idFlavour f of
357 DataConId dc -> False
359 ok_to_eta_reduce _ = False --safe. ToDo: generalise
361 eta (Let bind@(NonRec b r) body)
362 | not (any (`elemVarSet` fvs) bndrs)
364 Just e -> Just (Let bind e)
366 where fvs = exprFreeVars r
370 deLam expr = returnUs expr
372 -- ---------------------------------------------------------------------------
373 -- Precipitating the floating bindings
374 -- ---------------------------------------------------------------------------
376 mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr
377 mkBinds [] body = returnUs body
379 = deLam body `thenUs` \ body' ->
382 go [] body = returnUs body
383 go (b:bs) body = go bs body `thenUs` \ body' ->
387 mkBind (RecF prs) body = returnUs (Let (Rec prs) body)
389 mkBind (NonRecF bndr rhs dem floats) body
391 -- We shouldn't get let or case of the form v=w
392 = if exprIsTrivial rhs
393 then pprTrace "mkBind" (ppr bndr <+> ppr rhs)
394 (mk_let bndr rhs dem floats body)
395 else mk_let bndr rhs dem floats body
397 mk_let bndr rhs dem floats body
399 | isUnLiftedType bndr_rep_ty
400 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
401 mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
405 -- Strict let with WHNF rhs
407 Let (NonRec bndr rhs) body
409 -- Lazy let with WHNF rhs; float until we find a strict binding
411 (floats_out, floats_in) = splitFloats floats
413 mkBinds floats_in rhs `thenUs` \ new_rhs ->
415 Let (NonRec bndr new_rhs) body
417 | otherwise -- Not WHNF
419 -- Strict let with non-WHNF rhs
420 mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
422 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
423 mkBinds floats rhs `thenUs` \ new_rhs ->
424 returnUs (Let (NonRec bndr new_rhs) body)
427 bndr_rep_ty = repType (idType bndr)
428 is_strict = isStrictDem dem
429 is_whnf = exprIsValue rhs
431 splitFloats fs@(NonRecF _ _ dem _ : _)
432 | isStrictDem dem = ([], fs)
434 splitFloats (f : fs) = case splitFloats fs of
435 (fs_out, fs_in) -> (f : fs_out, fs_in)
437 splitFloats [] = ([], [])
439 -- -----------------------------------------------------------------------------
441 -- -----------------------------------------------------------------------------
444 = RhsDemand { isStrictDem :: Bool, -- True => used at least once
445 isOnceDem :: Bool -- True => used at most once
448 mkDem :: Demand -> Bool -> RhsDemand
449 mkDem strict once = RhsDemand (isStrict strict) once
451 mkDemTy :: Demand -> Type -> RhsDemand
452 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
454 isOnceTy :: Type -> Bool
458 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
463 once | u == usOnce = True
464 | u == usMany = False
465 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
467 bdrDem :: Id -> RhsDemand
468 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
470 safeDem, onceDem :: RhsDemand
471 safeDem = RhsDemand False False -- always safe to use this
472 onceDem = RhsDemand False True -- used at most once