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 ( saWwTopBinds ) where
12 #include "HsVersions.h"
14 import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats, opt_D_verbose_core2core )
16 import Id ( idType, setIdStrictness,
17 getIdDemandInfo, setIdDemandInfo,
20 import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo )
21 import CoreLint ( beginPass, endPass )
22 import ErrUtils ( dumpIfSet )
25 import Demand ( isStrict )
26 import WorkWrap -- "back-end" of strictness analyser
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 %************************************************************************
79 saWwTopBinds :: UniqSupply
85 beginPass "Strictness analysis";
87 -- Mark each binder with its strictness
88 #ifndef OMIT_STRANAL_STATS
89 let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
90 dumpIfSet opt_D_simplifier_stats "Strictness analysis statistics"
93 let { binds_w_strictness = saTopBindsBinds binds };
96 -- Create worker/wrappers, and mark binders with their
97 -- "strictness info" [which encodes their worker/wrapper-ness]
98 let { binds' = workersAndWrappers us binds_w_strictness };
100 endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds'
104 %************************************************************************
106 \subsection[saBinds]{Strictness analysis of bindings}
108 %************************************************************************
110 [Some of the documentation about types, etc., in \tr{SaLib} may be
111 helpful for understanding this module.]
113 @saTopBinds@ tags each binder in the program with its @Demand@.
114 That tells how each binder is {\em used}; if @Strict@, then the binder
115 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
116 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
118 (The above info is actually recorded for posterity in each binder's
119 IdInfo, notably its @DemandInfo@.)
121 We proceed by analysing the bindings top-to-bottom, building up an
122 environment which maps @Id@s to their abstract values (i.e., an
123 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
126 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
130 starting_abs_env = nullAbsValEnv
132 do_it starting_abs_env starting_abs_env binds
134 do_it _ _ [] = returnSa []
135 do_it senv aenv (b:bs)
136 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
137 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
138 returnSa (new_b : new_bs)
141 @saTopBind@ is only used for the top level. We don't add any demand
142 info to these ids because we can't work it out. In any case, it
143 doesn't do us any good to know whether top-level binders are sure to
144 be used; we can't turn top-level @let@s into @case@s.
147 saTopBind :: StrictEnv -> AbsenceEnv
149 -> SaM (StrictEnv, AbsenceEnv, CoreBind)
151 saTopBind str_env abs_env (NonRec binder rhs)
152 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
154 str_rhs = absEval StrAnal rhs str_env
155 abs_rhs = absEval AbsAnal rhs abs_env
157 widened_str_rhs = widen StrAnal str_rhs
158 widened_abs_rhs = widen AbsAnal abs_rhs
159 -- The widening above is done for efficiency reasons.
160 -- See notes on Let case in SaAbsInt.lhs
163 = addStrictnessInfoToId
164 widened_str_rhs widened_abs_rhs
168 -- Augment environments with a mapping of the
169 -- binder to its abstract values, computed by absEval
170 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
171 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
173 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
175 saTopBind str_env abs_env (Rec pairs)
177 (binders,rhss) = unzip pairs
178 str_rhss = fixpoint StrAnal binders rhss str_env
179 abs_rhss = fixpoint AbsAnal binders rhss abs_env
180 -- fixpoint returns widened values
181 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
182 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
183 new_binders = zipWith4Equal "saTopBind" addStrictnessInfoToId
184 str_rhss abs_rhss binders rhss
186 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
188 new_pairs = new_binders `zip` new_rhss
190 returnSa (new_str_env, new_abs_env, Rec new_pairs)
193 %************************************************************************
195 \subsection[saExpr]{Strictness analysis of an expression}
197 %************************************************************************
199 @saExpr@ computes the strictness of an expression within a given
203 saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
205 saExpr _ _ e@(Var _) = returnSa e
206 saExpr _ _ e@(Con _ _) = returnSa e
207 saExpr _ _ e@(Type _) = returnSa e
209 saExpr str_env abs_env (Lam bndr body)
210 = -- Don't bother to set the demand-info on a lambda binder
211 -- We do that only for let(rec)-bound functions
212 saExpr str_env abs_env body `thenSa` \ new_body ->
213 returnSa (Lam bndr new_body)
215 saExpr str_env abs_env (App fun arg)
216 = saExpr str_env abs_env fun `thenSa` \ new_fun ->
217 saExpr str_env abs_env arg `thenSa` \ new_arg ->
218 returnSa (App new_fun new_arg)
220 saExpr str_env abs_env (Note note expr)
221 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
222 returnSa (Note note new_expr)
224 saExpr str_env abs_env (Case expr case_bndr alts)
225 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
226 mapSa sa_alt alts `thenSa` \ new_alts ->
228 new_case_bndr = addDemandInfoToCaseBndr str_env abs_env alts case_bndr
230 returnSa (Case new_expr new_case_bndr new_alts)
232 sa_alt (con, binders, rhs)
233 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
235 new_binders = map add_demand_info binders
236 add_demand_info bndr | isTyVar bndr = bndr
237 | otherwise = addDemandInfoToId str_env abs_env rhs bndr
239 tickCases new_binders `thenSa_` -- stats
240 returnSa (con, new_binders, new_rhs)
242 saExpr str_env abs_env (Let (NonRec binder rhs) body)
243 = -- Analyse the RHS in the environment at hand
244 saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
246 -- Bind this binder to the abstract value of the RHS; analyse
247 -- the body of the `let' in the extended environment.
248 str_rhs_val = absEval StrAnal rhs str_env
249 abs_rhs_val = absEval AbsAnal rhs abs_env
251 widened_str_rhs = widen StrAnal str_rhs_val
252 widened_abs_rhs = widen AbsAnal abs_rhs_val
253 -- The widening above is done for efficiency reasons.
254 -- See notes on Let case in SaAbsInt.lhs
256 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
257 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
259 -- Now determine the strictness of this binder; use that info
260 -- to record DemandInfo/StrictnessInfo in the binder.
261 new_binder = addStrictnessInfoToId
262 widened_str_rhs widened_abs_rhs
263 (addDemandInfoToId str_env abs_env body binder)
266 tickLet new_binder `thenSa_` -- stats
267 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
268 returnSa (Let (NonRec new_binder new_rhs) new_body)
270 saExpr str_env abs_env (Let (Rec pairs) body)
272 (binders,rhss) = unzip pairs
273 str_vals = fixpoint StrAnal binders rhss str_env
274 abs_vals = fixpoint AbsAnal binders rhss abs_env
275 -- fixpoint returns widened values
276 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
277 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
279 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
280 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
282 -- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
283 -- DON'T add demand info in a Rec!
284 -- a) it's useless: we can't do let-to-case
285 -- b) it's incorrect. Consider
286 -- letrec x = ...y...
289 -- When we ask whether y is demanded we'll bind y to bottom and
290 -- evaluate the body of the letrec. But that will result in our
291 -- deciding that y is absent, which is plain wrong!
292 -- It's much easier simply not to do this.
294 improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId
295 str_vals abs_vals binders rhss
297 new_pairs = improved_binders `zip` new_rhss
299 returnSa (Let (Rec new_pairs) new_body)
303 %************************************************************************
305 \subsection[computeInfos]{Add computed info to binders}
307 %************************************************************************
309 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
310 let(rec) bound variables, and is use to attach the strictness (not
311 demand) info to the binder. We are careful to restrict this
312 strictness info to the lambda-bound arguments which are actually
313 visible, at the top level, lest we accidentally lose laziness by
314 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
315 rather syntactic way.
317 A better idea might be to have some kind of arity analysis to
318 tell how many args could safely be grabbed.
321 addStrictnessInfoToId
322 :: AbsVal -- Abstract strictness value
323 -> AbsVal -- Ditto absence
325 -> CoreExpr -- Its RHS
326 -> Id -- Augmented with strictness
328 addStrictnessInfoToId str_val abs_val binder body
331 = binder `setIdStrictness` mkBottomStrictnessInfo
334 = case (collectTyAndValBinders body) of
335 (_, [], rhs) -> binder
336 (_, lambda_bounds, rhs) -> binder `setIdStrictness`
337 mkStrictnessInfo strictness False
339 tys = map idType lambda_bounds
340 strictness = findStrictness tys str_val abs_val
344 addDemandInfoToId :: StrictEnv -> AbsenceEnv
345 -> CoreExpr -- The scope of the id
347 -> Id -- Id augmented with Demand info
349 addDemandInfoToId str_env abs_env expr binder
350 = binder `setIdDemandInfo` (findDemand str_env abs_env expr binder)
352 addDemandInfoToCaseBndr str_env abs_env alts binder
353 = binder `setIdDemandInfo` (findDemandAlts str_env abs_env alts binder)
355 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
357 addDemandInfoToIds str_env abs_env expr binders
358 = map (addDemandInfoToId str_env abs_env expr) binders
361 %************************************************************************
363 \subsection{Monad used herein for stats}
365 %************************************************************************
369 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
370 FAST_INT FAST_INT -- total/marked-demanded case-bound
371 FAST_INT FAST_INT -- total/marked-demanded let-bound
372 -- (excl. top-level; excl. letrecs)
374 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
376 thenSa :: SaM a -> (a -> SaM b) -> SaM b
377 thenSa_ :: SaM a -> SaM b -> SaM b
378 returnSa :: a -> SaM a
380 {-# INLINE thenSa #-}
381 {-# INLINE thenSa_ #-}
382 {-# INLINE returnSa #-}
384 tickLambda :: Id -> SaM ()
385 tickCases :: [CoreBndr] -> SaM ()
386 tickLet :: Id -> SaM ()
388 #ifndef OMIT_STRANAL_STATS
389 type SaM a = SaStats -> (a, SaStats)
391 thenSa expr cont stats
392 = case (expr stats) of { (result, stats1) ->
395 thenSa_ expr cont stats
396 = case (expr stats) of { (_, stats1) ->
399 returnSa x stats = (x, stats)
401 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
402 = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
403 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
405 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
406 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
407 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
409 tickLet var (SaStats tlam dlam tc dc tlet dlet)
410 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
411 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
413 tick_demanded var (tot, demanded)
414 | isTyVar var = (tot, demanded)
417 if (isStrict (getIdDemandInfo var))
421 pp_stats (SaStats tlam dlam tc dc tlet dlet)
422 = hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
423 ptext SLIT("; Case vars: "), int IBOX(dc), char '/', int IBOX(tc),
424 ptext SLIT("; Let vars: "), int IBOX(dlet), char '/', int IBOX(tlet)
427 #else {-OMIT_STRANAL_STATS-}
431 thenSa expr cont = cont expr
433 thenSa_ expr cont = cont
437 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
438 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
439 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
441 #endif {-OMIT_STRANAL_STATS-}
443 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
445 mapSa f [] = returnSa []
447 = f x `thenSa` \ r ->
448 mapSa f xs `thenSa` \ rs ->