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 let's 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 = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
167 coreSatExprFloat (Lit lit)
168 = returnUs ([], Lit lit)
170 coreSatExprFloat (Let bind body)
171 = coreSatBind bind `thenUs` \ new_bind ->
172 coreSatExprFloat body `thenUs` \ (floats, new_body) ->
173 returnUs (new_bind:floats, new_body)
175 coreSatExprFloat (Note other_note expr)
176 = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
177 returnUs (floats, Note other_note expr)
179 coreSatExprFloat expr@(Type _)
180 = returnUs ([], expr)
182 coreSatExprFloat (Lam v e)
183 = coreSatAnExpr e `thenUs` \ e' ->
184 returnUs ([], Lam v e')
186 coreSatExprFloat (Case scrut bndr alts)
187 = coreSatExprFloat scrut `thenUs` \ (floats, scrut) ->
188 mapUs sat_alt alts `thenUs` \ alts ->
189 mkCase scrut bndr alts `thenUs` \ expr ->
190 returnUs (floats, expr)
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
204 -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
205 returnUs (floats, app')
207 -> returnUs (floats, app)
213 -> Int -- current app depth
214 -> UniqSM (CoreExpr, -- the rebuilt expression
215 (CoreExpr,Int), -- the head of the application,
216 -- and no. of args it was applied to
217 Type, -- type of the whole expr
218 [FloatingBind], -- any floats we pulled out
219 [Demand]) -- remaining argument demands
221 collect_args (App fun arg@(Type arg_ty)) depth
222 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
223 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
225 collect_args (App fun arg) depth
226 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
228 (ss1, ss_rest) = case ss of
229 (ss1:ss_rest) -> (ss1, ss_rest)
231 (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $
232 splitFunTy_maybe fun_ty
234 coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
235 returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest)
237 collect_args (Var v) depth
238 = returnUs (Var v, (Var v, depth), idType v, [], stricts)
240 stricts = case idStrictness v of
241 StrictnessInfo demands _
242 | depth >= length demands -> demands
245 -- If depth < length demands, then we have too few args to
246 -- satisfy strictness info so we have to ignore all the
247 -- strictness info, e.g. + (error "urk")
248 -- Here, we can't evaluate the arg strictly, because this
249 -- partial application might be seq'd
251 collect_args (Note (Coerce ty1 ty2) fun) depth
252 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
253 returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
255 collect_args (Note note fun) depth
257 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
258 returnUs (Note note fun', hd, fun_ty, floats, ss)
260 -- non-variable fun, better let-bind it
261 collect_args fun depth
262 = newVar ty `thenUs` \ fn_id ->
263 coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
264 returnUs (Var fn_id, (Var fn_id, depth), ty,
265 [NonRecF fn_id fun onceDem fun_floats], [])
266 where ty = exprType fun
268 ignore_note InlineCall = True
269 ignore_note InlineMe = True
270 ignore_note _other = False
271 -- we don't ignore SCCs, since they require some code generation
273 ------------------------------------------------------------------------------
274 -- Generating new binders
275 -- ---------------------------------------------------------------------------
277 newVar :: Type -> UniqSM Id
279 = getUniqueUs `thenUs` \ uniq ->
281 returnUs (mkSysLocal SLIT("sat") uniq ty)
283 cloneTyVar :: TyVar -> UniqSM TyVar
285 = getUniqueUs `thenUs` \ uniq ->
286 returnUs (setTyVarUnique tv uniq)
288 ------------------------------------------------------------------------------
289 -- Building the saturated syntax
290 -- ---------------------------------------------------------------------------
292 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
293 -- mkApp deals with saturating primops and constructors
294 -- The type is the type of the entire application
295 maybeSaturate fn expr n_args ty
296 = case idFlavour fn of
297 PrimOpId (CCallOp ccall)
298 -- Sigh...make a guaranteed unique name for a dynamic ccall
299 -- Done here, not earlier, because it's a code-gen thing
300 -> getUniqueUs `thenUs` \ uniq ->
302 flavour = PrimOpId (CCallOp (setCCallUnique ccall uniq))
303 fn' = modifyIdInfo (`setFlavourInfo` flavour) fn
305 saturate fn' expr n_args ty
307 PrimOpId op -> saturate fn expr n_args ty
308 DataConId dc -> saturate fn expr n_args ty
309 other -> returnUs expr
311 saturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
312 -- The type should be the type of (id args)
313 -- The returned expression should also have this type
314 saturate fn expr n_args ty
315 = go excess_arity expr ty
317 fn_arity = idArity fn
318 excess_arity = fn_arity - n_args
321 | n == 0 -- Saturated, so nothing to do
324 | otherwise -- An unsaturated constructor or primop; eta expand it
325 = case splitForAllTy_maybe ty of {
326 Just (tv,ty') -> go n (App expr (Type (mkTyVarTy tv))) ty' `thenUs` \ expr' ->
327 returnUs (Lam tv expr') ;
330 case splitFunTy_maybe ty of {
331 Just (arg_ty, res_ty)
332 -> newVar arg_ty `thenUs` \ arg' ->
333 go (n-1) (App expr (Var arg')) res_ty `thenUs` \ expr' ->
334 returnUs (Lam arg' expr') ;
337 case splitNewType_maybe ty of {
338 Just ty' -> go n (mkCoerce ty' ty expr) ty' `thenUs` \ expr' ->
339 returnUs (mkCoerce ty ty' expr') ;
341 Nothing -> pprTrace "Bad saturate" ((ppr fn <+> ppr expr) $$ ppr ty)
347 -----------------------------------------------------------------------------
348 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
349 -----------------------------------------------------------------------------
352 = deLam e `thenUs` \ e ->
355 -- types will all disappear, so that's ok
356 deLam (Lam x e) | isTyVar x
357 = deLam e `thenUs` \ e ->
361 -- Try for eta reduction
365 -- Eta failed, so let-bind the lambda
367 = newVar (exprType expr) `thenUs` \ fn ->
368 returnUs (Let (NonRec fn expr) (Var fn))
371 (bndrs, body) = collectBinders expr
374 | n_remaining >= 0 &&
375 and (zipWith ok bndrs last_args) &&
376 not (any (`elemVarSet` fvs_remaining) bndrs)
377 = Just remaining_expr
379 (f, args) = collectArgs expr
380 remaining_expr = mkApps f remaining_args
381 fvs_remaining = exprFreeVars remaining_expr
382 (remaining_args, last_args) = splitAt n_remaining args
383 n_remaining = length args - length bndrs
385 ok bndr (Var arg) = bndr == arg
386 ok bndr other = False
388 eta (Let bind@(NonRec b r) body)
389 | not (any (`elemVarSet` fvs) bndrs)
391 Just e -> Just (Let bind e)
393 where fvs = exprFreeVars r
397 deLam expr = returnUs expr
399 -- ---------------------------------------------------------------------------
400 -- Precipitating the floating bindings
401 -- ---------------------------------------------------------------------------
403 mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr
404 mkBinds [] body = returnUs body
406 = deLam body `thenUs` \ body' ->
409 go [] body = returnUs body
410 go (b:bs) body = go bs body `thenUs` \ body' ->
414 mkBind (RecF prs) body = returnUs (Let (Rec prs) body)
416 mkBind (NonRecF bndr rhs dem floats) body
418 -- We shouldn't get let or case of the form v=w
419 = if exprIsTrivial rhs
420 then pprTrace "mkBind" (ppr bndr <+> ppr rhs)
421 (mk_let bndr rhs dem floats body)
422 else mk_let bndr rhs dem floats body
424 mk_let bndr rhs dem floats body
426 | isUnLiftedType bndr_rep_ty
427 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
428 mkCase rhs bndr [(DEFAULT, [], body)] `thenUs` \ expr' ->
433 -- Strict let with WHNF rhs
435 Let (NonRec bndr rhs) body
437 -- Lazy let with WHNF rhs; float until we find a strict binding
439 (floats_out, floats_in) = splitFloats floats
441 mkBinds floats_in rhs `thenUs` \ new_rhs ->
443 Let (NonRec bndr new_rhs) body
445 | otherwise -- Not WHNF
447 -- Strict let with non-WHNF rhs
448 mkCase rhs bndr [(DEFAULT, [], body)] `thenUs` \ expr' ->
451 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
452 mkBinds floats rhs `thenUs` \ new_rhs ->
453 returnUs (Let (NonRec bndr new_rhs) body)
456 bndr_rep_ty = repType (idType bndr)
457 is_strict = isStrictDem dem
458 is_whnf = exprIsValue rhs
460 splitFloats fs@(NonRecF _ _ dem _ : _)
461 | isStrictDem dem = ([], fs)
463 splitFloats (f : fs) = case splitFloats fs of
464 (fs_out, fs_in) -> (f : fs_out, fs_in)
466 splitFloats [] = ([], [])
468 -- -----------------------------------------------------------------------------
469 -- Making case expressions
470 -- -----------------------------------------------------------------------------
472 mkCase scrut bndr alts = returnUs (Case scrut bndr alts) -- ToDo
475 mkCase scrut@(App _ _) bndr alts
476 = let (f,args) = collectArgs scrut in
480 mkCase scrut@(StgPrimApp ParOp _ _) bndr
481 (StgPrimAlts tycon _ deflt@(StgBindDefault _))
482 = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
484 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
485 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
486 = mkStgCase scrut_expr new_bndr new_alts
488 new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
489 | otherwise = mkStgAlgAlts scrut_ty [] deflt
490 scrut_ty = stgArgType scrut
491 new_bndr = setIdType bndr scrut_ty
492 -- NB: SeqOp :: forall a. a -> Int#
493 -- So bndr has type Int#
494 -- But now we are going to scrutinise the SeqOp's argument directly,
495 -- so we must change the type of the case binder to match that
496 -- of the argument expression e.
498 scrut_expr = case scrut of
499 StgVarArg v -> StgApp v []
500 -- Others should not happen because
501 -- seq of a value should have disappeared
502 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
504 mkStgCase scrut bndr alts
505 = deStgLam scrut `thenUs` \ scrut' ->
506 -- It is (just) possible to get a lambda as a srutinee here
507 -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
508 -- gives: case ...Bool == Int->Int... of
509 -- True -> case coerce Bool (\x -> + 1 x) of
513 -- The True branch of the outer case will never happen, of course.
515 returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
518 -------------------------------------------------------------------------
520 -- -----------------------------------------------------------------------------
523 = RhsDemand { isStrictDem :: Bool, -- True => used at least once
524 isOnceDem :: Bool -- True => used at most once
527 mkDem :: Demand -> Bool -> RhsDemand
528 mkDem strict once = RhsDemand (isStrict strict) once
530 mkDemTy :: Demand -> Type -> RhsDemand
531 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
533 isOnceTy :: Type -> Bool
537 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
542 once | u == usOnce = True
543 | u == usMany = False
544 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
546 bdrDem :: Id -> RhsDemand
547 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
549 safeDem, onceDem :: RhsDemand
550 safeDem = RhsDemand False False -- always safe to use this
551 onceDem = RhsDemand False True -- used at most once