2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
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 #include "HsVersions.h"
12 module StrictAnal ( saWwTopBinds, saTopBinds ) where
14 import Id ( addIdDemandInfo, isWrapperId, addIdStrictness,
15 idType, getIdDemandInfo
22 import WorkWrap -- "back-end" of strictness analyser
23 import WwLib ( WwM(..) )
27 %************************************************************************
29 \subsection[Thoughts]{Random thoughts}
31 %************************************************************************
33 A note about worker-wrappering. If we have
36 f = let v = <expensive>
39 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
41 f = \x -> case x of Int x# -> fw x#
42 fw = \x# -> let x = Int x#
47 because this obviously loses laziness, since now <expensive>
48 is done each time. Alas.
50 WATCH OUT! This can mean that something is unboxed only to be
51 boxed again. For example
55 Here g is strict, and *will* split into worker-wrapper. A call to
56 g, with the wrapper inlined will then be
58 case arg of Int a# -> gw a#
60 Now g calls f, which has no wrapper, so it has to box it.
62 gw = \a# -> f (Int a#)
67 %************************************************************************
69 \subsection[iface-StrictAnal]{Interface to the outside world}
71 %************************************************************************
74 saWwTopBinds :: UniqSupply
75 -> (GlobalSwitch -> Bool)
79 saWwTopBinds us switch_chker binds
81 strflags = (switch_chker AllStrict, switch_chker NumbersStrict)
83 -- mark each binder with its strictness
84 #ifndef OMIT_STRANAL_STATS
85 (binds_w_strictness, sa_stats)
86 = sa_top_binds strflags binds nullSaStats
89 = sa_top_binds strflags binds
92 -- possibly show what we decided about strictness...
93 (if switch_chker D_dump_stranal
94 then pprTrace "Strictness:\n" (ppAboves (
95 map (pprCoreBinding PprDebug pprBigCoreBinder pprBigCoreBinder ppr) binds_w_strictness))
98 -- possibly show how many things we marked as demanded...
99 ((if switch_chker D_simplifier_stats
100 #ifndef OMIT_STRANAL_STATS
101 then pp_stats sa_stats
107 -- create worker/wrappers, and mark binders with their
108 -- "strictness info" [which encodes their
109 -- worker/wrapper-ness]
110 (workersAndWrappers binds_w_strictness us switch_chker))
111 #ifndef OMIT_STRANAL_STATS
113 pp_stats (SaStats tlam dlam tc dc tlet dlet)
114 = pprTrace "Binders marked demanded: "
115 (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
116 ppStr "; Case vars: ", ppInt IBOX(dc), ppChar '/', ppInt IBOX(tc),
117 ppStr "; Let vars: ", ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet)
122 %************************************************************************
124 \subsection[saBinds]{Strictness analysis of bindings}
126 %************************************************************************
128 [Some of the documentation about types, etc., in \tr{SaLib} may be
129 helpful for understanding this module.]
131 @saTopBinds@ tags each binder in the program with its @Demand@.
132 That tells how each binder is {\em used}; if @Strict@, then the binder
133 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
134 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
136 (The above info is actually recorded for posterity in each binder's
137 IdInfo, notably its @DemandInfo@.)
139 We proceed by analysing the bindings top-to-bottom, building up an
140 environment which maps @Id@s to their abstract values (i.e., an
141 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
144 saTopBinds :: StrAnalFlags -> [CoreBinding] -> [CoreBinding] -- exported
145 sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported
147 saTopBinds strflags binds
148 #ifndef OMIT_STRANAL_STATS
149 = fst (sa_top_binds strflags binds nullSaStats)
151 = sa_top_binds strflags binds
154 sa_top_binds strflags binds
156 starting_abs_env = nullAbsValEnv strflags
158 do_it starting_abs_env starting_abs_env binds
160 do_it _ _ [] = returnSa []
161 do_it senv aenv (b:bs)
162 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
163 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
164 returnSa (new_b : new_bs)
167 @saTopBind@ is only used for the top level. We don't add any demand
168 info to these ids because we can't work it out. In any case, it
169 doesn't do us any good to know whether top-level binders are sure to
170 be used; we can't turn top-level @let@s into @case@s.
173 saTopBind :: StrictEnv -> AbsenceEnv
175 -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
177 saTopBind str_env abs_env (NonRec binder rhs)
178 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
180 strflags = getStrAnalFlags str_env
182 str_rhs = absEval StrAnal rhs str_env
183 abs_rhs = absEval AbsAnal rhs abs_env
185 widened_str_rhs = widen StrAnal str_rhs
186 widened_abs_rhs = widen AbsAnal abs_rhs
187 -- The widening above is done for efficiency reasons.
188 -- See notes on Let case in SaAbsInt.lhs
191 = addStrictnessInfoToId
193 widened_str_rhs widened_abs_rhs
197 -- Augment environments with a mapping of the
198 -- binder to its abstract values, computed by absEval
199 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
200 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
202 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
204 saTopBind str_env abs_env (Rec pairs)
206 strflags = getStrAnalFlags str_env
207 (binders,rhss) = unzip pairs
208 str_rhss = fixpoint StrAnal binders rhss str_env
209 abs_rhss = fixpoint AbsAnal binders rhss abs_env
210 -- fixpoint returns widened values
211 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
212 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
213 new_binders = zipWith4Equal (addStrictnessInfoToId strflags)
214 str_rhss abs_rhss binders rhss
216 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
218 new_pairs = new_binders `zip` new_rhss
220 returnSa (new_str_env, new_abs_env, Rec new_pairs)
223 %************************************************************************
225 \subsection[saExpr]{Strictness analysis of an expression}
227 %************************************************************************
229 @saExpr@ computes the strictness of an expression within a given
233 saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
235 saExpr _ _ e@(Var _) = returnSa e
236 saExpr _ _ e@(Lit _) = returnSa e
237 saExpr _ _ e@(Con _ _ _) = returnSa e
238 saExpr _ _ e@(Prim _ _ _) = returnSa e
240 saExpr str_env abs_env (Lam arg body)
241 = saExpr str_env abs_env body `thenSa` \ new_body ->
243 new_arg = addDemandInfoToId str_env abs_env body arg
245 tickLambda new_arg `thenSa_` -- stats
246 returnSa (Lam new_arg new_body)
248 saExpr str_env abs_env (CoTyLam ty expr)
249 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
250 returnSa (CoTyLam ty new_expr)
252 saExpr str_env abs_env (App fun arg)
253 = saExpr str_env abs_env fun `thenSa` \ new_fun ->
254 returnSa (App new_fun arg)
256 saExpr str_env abs_env (CoTyApp expr ty)
257 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
258 returnSa (CoTyApp new_expr ty)
260 saExpr str_env abs_env (SCC cc expr)
261 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
262 returnSa (SCC cc new_expr)
264 saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
265 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
266 saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
267 mapSa sa_alt alts `thenSa` \ new_alts ->
268 returnSa (Case new_expr (AlgAlts new_alts new_deflt))
270 sa_alt (con, binders, rhs)
271 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
273 new_binders = addDemandInfoToIds str_env abs_env rhs binders
275 tickCases new_binders `thenSa_` -- stats
276 returnSa (con, new_binders, new_rhs)
278 saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
279 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
280 saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
281 mapSa sa_alt alts `thenSa` \ new_alts ->
282 returnSa (Case new_expr (PrimAlts new_alts new_deflt))
285 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
286 returnSa (lit, new_rhs)
288 saExpr str_env abs_env (Let (NonRec binder rhs) body)
289 = -- Analyse the RHS in the environment at hand
290 saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
292 strflags = getStrAnalFlags str_env
294 -- Bind this binder to the abstract value of the RHS; analyse
295 -- the body of the `let' in the extended environment.
296 str_rhs_val = absEval StrAnal rhs str_env
297 abs_rhs_val = absEval AbsAnal rhs abs_env
299 widened_str_rhs = widen StrAnal str_rhs_val
300 widened_abs_rhs = widen AbsAnal abs_rhs_val
301 -- The widening above is done for efficiency reasons.
302 -- See notes on Let case in SaAbsInt.lhs
304 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
305 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
307 -- Now determine the strictness of this binder; use that info
308 -- to record DemandInfo/StrictnessInfo in the binder.
309 new_binder = addStrictnessInfoToId strflags
310 widened_str_rhs widened_abs_rhs
311 (addDemandInfoToId str_env abs_env body binder)
314 tickLet new_binder `thenSa_` -- stats
315 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
316 returnSa (Let (NonRec new_binder new_rhs) new_body)
318 saExpr str_env abs_env (Let (Rec pairs) body)
320 strflags = getStrAnalFlags str_env
321 (binders,rhss) = unzip pairs
322 str_vals = fixpoint StrAnal binders rhss str_env
323 abs_vals = fixpoint AbsAnal binders rhss abs_env
324 -- fixpoint returns widened values
325 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
326 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
328 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
329 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
331 -- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
332 -- DON'T add demand info in a Rec!
333 -- a) it's useless: we can't do let-to-case
334 -- b) it's incorrect. Consider
335 -- letrec x = ...y...
338 -- When we ask whether y is demanded we'll bind y to bottom and
339 -- evaluate the body of the letrec. But that will result in our
340 -- deciding that y is absent, which is plain wrong!
341 -- It's much easier simply not to do this.
343 improved_binders = zipWith4Equal (addStrictnessInfoToId strflags)
344 str_vals abs_vals binders rhss
346 whiter_than_white_binders = launder improved_binders
348 new_pairs = whiter_than_white_binders `zip` new_rhss
350 returnSa (Let (Rec new_pairs) new_body)
352 launder me = {-still-} me
356 saDefault str_env abs_env NoDefault = returnSa NoDefault
358 saDefault str_env abs_env (BindDefault bdr rhs)
359 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
361 new_bdr = addDemandInfoToId str_env abs_env rhs bdr
363 tickCases [new_bdr] `thenSa_` -- stats
364 returnSa (BindDefault new_bdr new_rhs)
368 %************************************************************************
370 \subsection[computeInfos]{Add computed info to binders}
372 %************************************************************************
374 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
375 let(rec) bound variables, and is use to attach the strictness (not
376 demand) info to the binder. We are careful to restrict this
377 strictness info to the lambda-bound arguments which are actually
378 visible, at the top level, lest we accidentally lose laziness by
379 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
380 rather syntactic way.
382 A better idea might be to have some kind of arity analysis to
383 tell how many args could safely be grabbed.
386 addStrictnessInfoToId
388 -> AbsVal -- Abstract strictness value
389 -> AbsVal -- Ditto absence
391 -> CoreExpr -- Its RHS
392 -> Id -- Augmented with strictness
394 addStrictnessInfoToId strflags str_val abs_val binder body
395 = if isWrapperId binder then
396 binder -- Avoid clobbering existing strictness info
397 -- (and, more importantly, worker info).
398 -- Deeply suspicious (SLPJ)
400 if (isBot str_val) then
401 binder `addIdStrictness` mkBottomStrictnessInfo
403 case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
405 tys = map idType lambda_bounds
406 strictness = findStrictness strflags tys str_val abs_val
408 binder `addIdStrictness` mkStrictnessInfo strictness Nothing
413 addDemandInfoToId :: StrictEnv -> AbsenceEnv
414 -> CoreExpr -- The scope of the id
416 -> Id -- Id augmented with Demand info
418 addDemandInfoToId str_env abs_env expr binder
419 = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
421 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
423 addDemandInfoToIds str_env abs_env expr binders
424 = map (addDemandInfoToId str_env abs_env expr) binders
427 %************************************************************************
429 \subsection{Monad used herein for stats}
431 %************************************************************************
435 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
436 FAST_INT FAST_INT -- total/marked-demanded case-bound
437 FAST_INT FAST_INT -- total/marked-demanded let-bound
438 -- (excl. top-level; excl. letrecs)
440 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
442 thenSa :: SaM a -> (a -> SaM b) -> SaM b
443 thenSa_ :: SaM a -> SaM b -> SaM b
444 returnSa :: a -> SaM a
446 {-# INLINE thenSa #-}
447 {-# INLINE thenSa_ #-}
448 {-# INLINE returnSa #-}
450 tickLambda :: [Id] -> SaM ()
451 tickCases :: [Id] -> SaM ()
452 tickLet :: Id -> SaM ()
454 #ifndef OMIT_STRANAL_STATS
455 type SaM a = SaStats -> (a, SaStats)
457 thenSa expr cont stats
458 = case (expr stats) of { (result, stats1) ->
461 thenSa_ expr cont stats
462 = case (expr stats) of { (_, stats1) ->
465 returnSa x stats = (x, stats)
467 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
468 = case (tick_demanded (0,0) var) of { (IBOX(tot), IBOX(demanded)) ->
469 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
471 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
472 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
473 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
475 tickLet var (SaStats tlam dlam tc dc tlet dlet)
476 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
477 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
479 tick_demanded var (tot, demanded)
481 if (willBeDemanded (getIdDemandInfo var))
485 #else {-OMIT_STRANAL_STATS-}
489 thenSa expr cont = cont expr
491 thenSa_ expr cont = cont
495 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
496 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
497 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
499 #endif {-OMIT_STRANAL_STATS-}
501 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
503 mapSa f [] = returnSa []
505 = f x `thenSa` \ r ->
506 mapSa f xs `thenSa` \ rs ->