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 ErrUtils ( dumpIfSet )
25 import Demand ( isStrict )
26 import UniqSupply ( UniqSupply )
27 import Util ( zipWith4Equal )
31 %************************************************************************
33 \subsection[Thoughts]{Random thoughts}
35 %************************************************************************
37 A note about worker-wrappering. If we have
40 f = let v = <expensive>
43 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
45 f = \x -> case x of Int x# -> fw x#
46 fw = \x# -> let x = Int x#
51 because this obviously loses laziness, since now <expensive>
52 is done each time. Alas.
54 WATCH OUT! This can mean that something is unboxed only to be
55 boxed again. For example
59 Here g is strict, and *will* split into worker-wrapper. A call to
60 g, with the wrapper inlined will then be
62 case arg of Int a# -> gw a#
64 Now g calls f, which has no wrapper, so it has to box it.
66 gw = \a# -> f (Int a#)
71 %************************************************************************
73 \subsection[iface-StrictAnal]{Interface to the outside world}
75 %************************************************************************
77 @saBinds@ decorates bindings with strictness info. A later
78 worker-wrapper pass can use this info to create wrappers and
87 beginPass "Strictness analysis";
89 -- Mark each binder with its strictness
90 #ifndef OMIT_STRANAL_STATS
91 let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
92 dumpIfSet opt_D_dump_simpl_stats "Strictness analysis statistics"
95 let { binds_w_strictness = saTopBindsBinds binds };
98 endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds_w_strictness
102 %************************************************************************
104 \subsection[saBinds]{Strictness analysis of bindings}
106 %************************************************************************
108 [Some of the documentation about types, etc., in \tr{SaLib} may be
109 helpful for understanding this module.]
111 @saTopBinds@ tags each binder in the program with its @Demand@.
112 That tells how each binder is {\em used}; if @Strict@, then the binder
113 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
114 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
116 (The above info is actually recorded for posterity in each binder's
117 IdInfo, notably its @DemandInfo@.)
119 We proceed by analysing the bindings top-to-bottom, building up an
120 environment which maps @Id@s to their abstract values (i.e., an
121 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
124 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
128 starting_abs_env = nullAbsValEnv
130 do_it starting_abs_env starting_abs_env binds
132 do_it _ _ [] = returnSa []
133 do_it senv aenv (b:bs)
134 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
135 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
136 returnSa (new_b : new_bs)
139 @saTopBind@ is only used for the top level. We don't add any demand
140 info to these ids because we can't work it out. In any case, it
141 doesn't do us any good to know whether top-level binders are sure to
142 be used; we can't turn top-level @let@s into @case@s.
145 saTopBind :: StrictEnv -> AbsenceEnv
147 -> SaM (StrictEnv, AbsenceEnv, CoreBind)
149 saTopBind str_env abs_env (NonRec binder rhs)
150 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
152 str_rhs = absEval StrAnal rhs str_env
153 abs_rhs = absEval AbsAnal rhs abs_env
155 widened_str_rhs = widen StrAnal str_rhs
156 widened_abs_rhs = widen AbsAnal abs_rhs
157 -- The widening above is done for efficiency reasons.
158 -- See notes on Let case in SaAbsInt.lhs
161 = addStrictnessInfoToId
162 widened_str_rhs widened_abs_rhs
166 -- Augment environments with a mapping of the
167 -- binder to its abstract values, computed by absEval
168 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
169 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
171 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
173 saTopBind str_env abs_env (Rec pairs)
175 (binders,rhss) = unzip pairs
176 str_rhss = fixpoint StrAnal binders rhss str_env
177 abs_rhss = fixpoint AbsAnal binders rhss abs_env
178 -- fixpoint returns widened values
179 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
180 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
181 new_binders = zipWith4Equal "saTopBind" addStrictnessInfoToId
182 str_rhss abs_rhss binders rhss
184 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
186 new_pairs = new_binders `zip` new_rhss
188 returnSa (new_str_env, new_abs_env, Rec new_pairs)
191 %************************************************************************
193 \subsection[saExpr]{Strictness analysis of an expression}
195 %************************************************************************
197 @saExpr@ computes the strictness of an expression within a given
201 saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
203 saExpr _ _ e@(Var _) = returnSa e
204 saExpr _ _ e@(Con _ _) = returnSa e
205 saExpr _ _ e@(Type _) = returnSa e
207 saExpr str_env abs_env (Lam bndr body)
208 = -- Don't bother to set the demand-info on a lambda binder
209 -- We do that only for let(rec)-bound functions
210 saExpr str_env abs_env body `thenSa` \ new_body ->
211 returnSa (Lam bndr new_body)
213 saExpr str_env abs_env (App fun arg)
214 = saExpr str_env abs_env fun `thenSa` \ new_fun ->
215 saExpr str_env abs_env arg `thenSa` \ new_arg ->
216 returnSa (App new_fun new_arg)
218 saExpr str_env abs_env (Note note expr)
219 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
220 returnSa (Note note new_expr)
222 saExpr str_env abs_env (Case expr case_bndr alts)
223 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
224 mapSa sa_alt alts `thenSa` \ new_alts ->
226 new_case_bndr = addDemandInfoToCaseBndr str_env abs_env alts case_bndr
228 returnSa (Case new_expr new_case_bndr new_alts)
230 sa_alt (con, binders, rhs)
231 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
233 new_binders = map add_demand_info binders
234 add_demand_info bndr | isTyVar bndr = bndr
235 | otherwise = addDemandInfoToId str_env abs_env rhs bndr
237 tickCases new_binders `thenSa_` -- stats
238 returnSa (con, new_binders, new_rhs)
240 saExpr str_env abs_env (Let (NonRec binder rhs) body)
241 = -- Analyse the RHS in the environment at hand
242 saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
244 -- Bind this binder to the abstract value of the RHS; analyse
245 -- the body of the `let' in the extended environment.
246 str_rhs_val = absEval StrAnal rhs str_env
247 abs_rhs_val = absEval AbsAnal rhs abs_env
249 widened_str_rhs = widen StrAnal str_rhs_val
250 widened_abs_rhs = widen AbsAnal abs_rhs_val
251 -- The widening above is done for efficiency reasons.
252 -- See notes on Let case in SaAbsInt.lhs
254 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
255 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
257 -- Now determine the strictness of this binder; use that info
258 -- to record DemandInfo/StrictnessInfo in the binder.
259 new_binder = addStrictnessInfoToId
260 widened_str_rhs widened_abs_rhs
261 (addDemandInfoToId str_env abs_env body binder)
264 tickLet new_binder `thenSa_` -- stats
265 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
266 returnSa (Let (NonRec new_binder new_rhs) new_body)
268 saExpr str_env abs_env (Let (Rec pairs) body)
270 (binders,rhss) = unzip pairs
271 str_vals = fixpoint StrAnal binders rhss str_env
272 abs_vals = fixpoint AbsAnal binders rhss abs_env
273 -- fixpoint returns widened values
274 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
275 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
277 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
278 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
280 -- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
281 -- DON'T add demand info in a Rec!
282 -- a) it's useless: we can't do let-to-case
283 -- b) it's incorrect. Consider
284 -- letrec x = ...y...
287 -- When we ask whether y is demanded we'll bind y to bottom and
288 -- evaluate the body of the letrec. But that will result in our
289 -- deciding that y is absent, which is plain wrong!
290 -- It's much easier simply not to do this.
292 improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId
293 str_vals abs_vals binders rhss
295 new_pairs = improved_binders `zip` new_rhss
297 returnSa (Let (Rec new_pairs) new_body)
301 %************************************************************************
303 \subsection[computeInfos]{Add computed info to binders}
305 %************************************************************************
307 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
308 let(rec) bound variables, and is use to attach the strictness (not
309 demand) info to the binder. We are careful to restrict this
310 strictness info to the lambda-bound arguments which are actually
311 visible, at the top level, lest we accidentally lose laziness by
312 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
313 rather syntactic way.
315 A better idea might be to have some kind of arity analysis to
316 tell how many args could safely be grabbed.
319 addStrictnessInfoToId
320 :: AbsVal -- Abstract strictness value
321 -> AbsVal -- Ditto absence
323 -> CoreExpr -- Its RHS
324 -> Id -- Augmented with strictness
326 addStrictnessInfoToId str_val abs_val binder body
327 = case collectBindersIgnoringNotes body of
328 -- It's imporant to use collectBindersIgnoringNotes, so that INLINE prags
329 -- don't inhibit strictness info. In particular, foldr is marked INLINE,
330 -- but we still want it to be strict in its third arg, so that
331 -- foldr k z (case e of p -> build g)
332 -- gets transformed to
333 -- case e of p -> foldr k z (build g)
334 (binders, rhs) -> binder `setIdStrictness`
335 mkStrictnessInfo strictness
337 tys = [idType id | id <- binders, isId id]
338 strictness = findStrictness tys str_val abs_val
342 addDemandInfoToId :: StrictEnv -> AbsenceEnv
343 -> CoreExpr -- The scope of the id
345 -> Id -- Id augmented with Demand info
347 addDemandInfoToId str_env abs_env expr binder
348 = binder `setIdDemandInfo` (findDemand str_env abs_env expr binder)
350 addDemandInfoToCaseBndr str_env abs_env alts binder
351 = binder `setIdDemandInfo` (findDemandAlts str_env abs_env alts binder)
353 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
355 addDemandInfoToIds str_env abs_env expr binders
356 = map (addDemandInfoToId str_env abs_env expr) binders
359 %************************************************************************
361 \subsection{Monad used herein for stats}
363 %************************************************************************
367 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
368 FAST_INT FAST_INT -- total/marked-demanded case-bound
369 FAST_INT FAST_INT -- total/marked-demanded let-bound
370 -- (excl. top-level; excl. letrecs)
372 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
374 thenSa :: SaM a -> (a -> SaM b) -> SaM b
375 thenSa_ :: SaM a -> SaM b -> SaM b
376 returnSa :: a -> SaM a
378 {-# INLINE thenSa #-}
379 {-# INLINE thenSa_ #-}
380 {-# INLINE returnSa #-}
382 tickLambda :: Id -> SaM ()
383 tickCases :: [CoreBndr] -> SaM ()
384 tickLet :: Id -> SaM ()
386 #ifndef OMIT_STRANAL_STATS
387 type SaM a = SaStats -> (a, SaStats)
389 thenSa expr cont stats
390 = case (expr stats) of { (result, stats1) ->
393 thenSa_ expr cont stats
394 = case (expr stats) of { (_, stats1) ->
397 returnSa x stats = (x, stats)
399 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
400 = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
401 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
403 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
404 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
405 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
407 tickLet var (SaStats tlam dlam tc dc tlet dlet)
408 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
409 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
411 tick_demanded var (tot, demanded)
412 | isTyVar var = (tot, demanded)
415 if (isStrict (getIdDemandInfo var))
419 pp_stats (SaStats tlam dlam tc dc tlet dlet)
420 = hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
421 ptext SLIT("; Case vars: "), int IBOX(dc), char '/', int IBOX(tc),
422 ptext SLIT("; Let vars: "), int IBOX(dlet), char '/', int IBOX(tlet)
425 #else {-OMIT_STRANAL_STATS-}
429 thenSa expr cont = cont expr
431 thenSa_ expr cont = cont
435 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
436 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
437 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
439 #endif {-OMIT_STRANAL_STATS-}
441 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
443 mapSa f [] = returnSa []
445 = f x `thenSa` \ r ->
446 mapSa f xs `thenSa` \ rs ->