2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
6 The original version(s) of all strictness-analyser code (except the
7 Semantique analyser) was written by Andy Gill.
10 module StrictAnal ( saBinds ) where
12 #include "HsVersions.h"
14 import CmdLineOpts ( opt_D_dump_stranal, opt_D_dump_simpl_stats, opt_D_verbose_core2core )
16 import Id ( idType, setIdStrictness,
17 getIdDemandInfo, setIdDemandInfo,
20 import IdInfo ( mkStrictnessInfo )
21 import CoreLint ( beginPass, endPass )
22 import Type ( repType, splitFunTys )
23 import ErrUtils ( dumpIfSet )
26 import Demand ( isStrict )
27 import UniqSupply ( UniqSupply )
28 import Util ( zipWith4Equal )
32 %************************************************************************
34 \subsection[Thoughts]{Random thoughts}
36 %************************************************************************
38 A note about worker-wrappering. If we have
41 f = let v = <expensive>
44 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
46 f = \x -> case x of Int x# -> fw x#
47 fw = \x# -> let x = Int x#
52 because this obviously loses laziness, since now <expensive>
53 is done each time. Alas.
55 WATCH OUT! This can mean that something is unboxed only to be
56 boxed again. For example
60 Here g is strict, and *will* split into worker-wrapper. A call to
61 g, with the wrapper inlined will then be
63 case arg of Int a# -> gw a#
65 Now g calls f, which has no wrapper, so it has to box it.
67 gw = \a# -> f (Int a#)
72 %************************************************************************
74 \subsection[iface-StrictAnal]{Interface to the outside world}
76 %************************************************************************
78 @saBinds@ decorates bindings with strictness info. A later
79 worker-wrapper pass can use this info to create wrappers and
88 beginPass "Strictness analysis";
90 -- Mark each binder with its strictness
91 #ifndef OMIT_STRANAL_STATS
92 let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
93 dumpIfSet opt_D_dump_simpl_stats "Strictness analysis statistics"
96 let { binds_w_strictness = saTopBindsBinds binds };
99 endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds_w_strictness
103 %************************************************************************
105 \subsection[saBinds]{Strictness analysis of bindings}
107 %************************************************************************
109 [Some of the documentation about types, etc., in \tr{SaLib} may be
110 helpful for understanding this module.]
112 @saTopBinds@ tags each binder in the program with its @Demand@.
113 That tells how each binder is {\em used}; if @Strict@, then the binder
114 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
115 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
117 (The above info is actually recorded for posterity in each binder's
118 IdInfo, notably its @DemandInfo@.)
120 We proceed by analysing the bindings top-to-bottom, building up an
121 environment which maps @Id@s to their abstract values (i.e., an
122 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
125 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
129 starting_abs_env = nullAbsValEnv
131 do_it starting_abs_env starting_abs_env binds
133 do_it _ _ [] = returnSa []
134 do_it senv aenv (b:bs)
135 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
136 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
137 returnSa (new_b : new_bs)
140 @saTopBind@ is only used for the top level. We don't add any demand
141 info to these ids because we can't work it out. In any case, it
142 doesn't do us any good to know whether top-level binders are sure to
143 be used; we can't turn top-level @let@s into @case@s.
146 saTopBind :: StrictEnv -> AbsenceEnv
148 -> SaM (StrictEnv, AbsenceEnv, CoreBind)
150 saTopBind str_env abs_env (NonRec binder rhs)
151 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
153 str_rhs = absEval StrAnal rhs str_env
154 abs_rhs = absEval AbsAnal rhs abs_env
156 widened_str_rhs = widen StrAnal str_rhs
157 widened_abs_rhs = widen AbsAnal abs_rhs
158 -- The widening above is done for efficiency reasons.
159 -- See notes on Let case in SaAbsInt.lhs
162 = addStrictnessInfoToId
163 widened_str_rhs widened_abs_rhs
167 -- Augment environments with a mapping of the
168 -- binder to its abstract values, computed by absEval
169 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
170 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
172 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
174 saTopBind str_env abs_env (Rec pairs)
176 (binders,rhss) = unzip pairs
177 str_rhss = fixpoint StrAnal binders rhss str_env
178 abs_rhss = fixpoint AbsAnal binders rhss abs_env
179 -- fixpoint returns widened values
180 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
181 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
182 new_binders = zipWith4Equal "saTopBind" addStrictnessInfoToId
183 str_rhss abs_rhss binders rhss
185 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
187 new_pairs = new_binders `zip` new_rhss
189 returnSa (new_str_env, new_abs_env, Rec new_pairs)
192 %************************************************************************
194 \subsection[saExpr]{Strictness analysis of an expression}
196 %************************************************************************
198 @saExpr@ computes the strictness of an expression within a given
202 saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
204 saExpr _ _ e@(Var _) = returnSa e
205 saExpr _ _ e@(Con _ _) = returnSa e
206 saExpr _ _ e@(Type _) = returnSa e
208 saExpr str_env abs_env (Lam bndr body)
209 = -- Don't bother to set the demand-info on a lambda binder
210 -- We do that only for let(rec)-bound functions
211 saExpr str_env abs_env body `thenSa` \ new_body ->
212 returnSa (Lam bndr new_body)
214 saExpr str_env abs_env (App fun arg)
215 = saExpr str_env abs_env fun `thenSa` \ new_fun ->
216 saExpr str_env abs_env arg `thenSa` \ new_arg ->
217 returnSa (App new_fun new_arg)
219 saExpr str_env abs_env (Note note expr)
220 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
221 returnSa (Note note new_expr)
223 saExpr str_env abs_env (Case expr case_bndr alts)
224 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
225 mapSa sa_alt alts `thenSa` \ new_alts ->
227 new_case_bndr = addDemandInfoToCaseBndr str_env abs_env alts case_bndr
229 returnSa (Case new_expr new_case_bndr new_alts)
231 sa_alt (con, binders, rhs)
232 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
234 new_binders = map add_demand_info binders
235 add_demand_info bndr | isTyVar bndr = bndr
236 | otherwise = addDemandInfoToId str_env abs_env rhs bndr
238 tickCases new_binders `thenSa_` -- stats
239 returnSa (con, new_binders, new_rhs)
241 saExpr str_env abs_env (Let (NonRec binder rhs) body)
242 = -- Analyse the RHS in the environment at hand
243 saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
245 -- Bind this binder to the abstract value of the RHS; analyse
246 -- the body of the `let' in the extended environment.
247 str_rhs_val = absEval StrAnal rhs str_env
248 abs_rhs_val = absEval AbsAnal rhs abs_env
250 widened_str_rhs = widen StrAnal str_rhs_val
251 widened_abs_rhs = widen AbsAnal abs_rhs_val
252 -- The widening above is done for efficiency reasons.
253 -- See notes on Let case in SaAbsInt.lhs
255 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
256 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
258 -- Now determine the strictness of this binder; use that info
259 -- to record DemandInfo/StrictnessInfo in the binder.
260 new_binder = addStrictnessInfoToId
261 widened_str_rhs widened_abs_rhs
262 (addDemandInfoToId str_env abs_env body binder)
265 tickLet new_binder `thenSa_` -- stats
266 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
267 returnSa (Let (NonRec new_binder new_rhs) new_body)
269 saExpr str_env abs_env (Let (Rec pairs) body)
271 (binders,rhss) = unzip pairs
272 str_vals = fixpoint StrAnal binders rhss str_env
273 abs_vals = fixpoint AbsAnal binders rhss abs_env
274 -- fixpoint returns widened values
275 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
276 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
278 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
279 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
281 -- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
282 -- DON'T add demand info in a Rec!
283 -- a) it's useless: we can't do let-to-case
284 -- b) it's incorrect. Consider
285 -- letrec x = ...y...
288 -- When we ask whether y is demanded we'll bind y to bottom and
289 -- evaluate the body of the letrec. But that will result in our
290 -- deciding that y is absent, which is plain wrong!
291 -- It's much easier simply not to do this.
293 improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId
294 str_vals abs_vals binders rhss
296 new_pairs = improved_binders `zip` new_rhss
298 returnSa (Let (Rec new_pairs) new_body)
302 %************************************************************************
304 \subsection[computeInfos]{Add computed info to binders}
306 %************************************************************************
308 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
309 let(rec) bound variables, and is use to attach the strictness (not
310 demand) info to the binder. We are careful to restrict this
311 strictness info to the lambda-bound arguments which are actually
312 visible, at the top level, lest we accidentally lose laziness by
313 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
314 rather syntactic way.
316 A better idea might be to have some kind of arity analysis to
317 tell how many args could safely be grabbed.
320 addStrictnessInfoToId
321 :: AbsVal -- Abstract strictness value
322 -> AbsVal -- Ditto absence
324 -> CoreExpr -- Its RHS
325 -> Id -- Augmented with strictness
327 addStrictnessInfoToId str_val abs_val binder body
328 = binder `setIdStrictness` mkStrictnessInfo strictness
330 arg_tys = collect_arg_tys (idType binder)
331 strictness = findStrictness arg_tys str_val abs_val
335 | otherwise = arg_tys ++ collect_arg_tys res_ty
337 (arg_tys, res_ty) = splitFunTys (repType ty)
338 -- repType looks through for-alls and new-types. And since we look on the
339 -- type info, we aren't confused by INLINE prags.
340 -- In particular, foldr is marked INLINE,
341 -- but we still want it to be strict in its third arg, so that
342 -- foldr k z (case e of p -> build g)
343 -- gets transformed to
344 -- case e of p -> foldr k z (build g)
345 -- [foldr is only inlined late in compilation, after strictness analysis]
349 addDemandInfoToId :: StrictEnv -> AbsenceEnv
350 -> CoreExpr -- The scope of the id
352 -> Id -- Id augmented with Demand info
354 addDemandInfoToId str_env abs_env expr binder
355 = binder `setIdDemandInfo` (findDemand str_env abs_env expr binder)
357 addDemandInfoToCaseBndr str_env abs_env alts binder
358 = binder `setIdDemandInfo` (findDemandAlts str_env abs_env alts binder)
360 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
362 addDemandInfoToIds str_env abs_env expr binders
363 = map (addDemandInfoToId str_env abs_env expr) binders
366 %************************************************************************
368 \subsection{Monad used herein for stats}
370 %************************************************************************
374 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
375 FAST_INT FAST_INT -- total/marked-demanded case-bound
376 FAST_INT FAST_INT -- total/marked-demanded let-bound
377 -- (excl. top-level; excl. letrecs)
379 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
381 thenSa :: SaM a -> (a -> SaM b) -> SaM b
382 thenSa_ :: SaM a -> SaM b -> SaM b
383 returnSa :: a -> SaM a
385 {-# INLINE thenSa #-}
386 {-# INLINE thenSa_ #-}
387 {-# INLINE returnSa #-}
389 tickLambda :: Id -> SaM ()
390 tickCases :: [CoreBndr] -> SaM ()
391 tickLet :: Id -> SaM ()
393 #ifndef OMIT_STRANAL_STATS
394 type SaM a = SaStats -> (a, SaStats)
396 thenSa expr cont stats
397 = case (expr stats) of { (result, stats1) ->
400 thenSa_ expr cont stats
401 = case (expr stats) of { (_, stats1) ->
404 returnSa x stats = (x, stats)
406 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
407 = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
408 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
410 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
411 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
412 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
414 tickLet var (SaStats tlam dlam tc dc tlet dlet)
415 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
416 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
418 tick_demanded var (tot, demanded)
419 | isTyVar var = (tot, demanded)
422 if (isStrict (getIdDemandInfo var))
426 pp_stats (SaStats tlam dlam tc dc tlet dlet)
427 = hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
428 ptext SLIT("; Case vars: "), int IBOX(dc), char '/', int IBOX(tc),
429 ptext SLIT("; Let vars: "), int IBOX(dlet), char '/', int IBOX(tlet)
432 #else {-OMIT_STRANAL_STATS-}
436 thenSa expr cont = cont expr
438 thenSa_ expr cont = cont
442 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
443 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
444 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
446 #endif {-OMIT_STRANAL_STATS-}
448 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
450 mapSa f [] = returnSa []
452 = f x `thenSa` \ r ->
453 mapSa f xs `thenSa` \ rs ->