2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
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
18 import CmdLineOpts ( GlobalSwitch(..) )
19 import CoreSyn -- ToDo: get pprCoreBinding straight from PlainCore?
20 import Id ( addIdDemandInfo, isWrapperId, addIdStrictness,
21 getIdUniType, getIdDemandInfo
22 IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
32 import WorkWrap -- "back-end" of strictness analyser
33 import WwLib ( WwM(..) )
37 %************************************************************************
39 \subsection[Thoughts]{Random thoughts}
41 %************************************************************************
43 A note about worker-wrappering. If we have
46 f = let v = <expensive>
49 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
51 f = \x -> case x of Int x# -> fw x#
52 fw = \x# -> let x = Int x#
57 because this obviously loses laziness, since now <expensive>
58 is done each time. Alas.
60 WATCH OUT! This can mean that something is unboxed only to be
61 boxed again. For example
65 Here g is strict, and *will* split into worker-wrapper. A call to
66 g, with the wrapper inlined will then be
68 case arg of Int a# -> gw a#
70 Now g calls f, which has no wrapper, so it has to box it.
72 gw = \a# -> f (Int a#)
77 %************************************************************************
79 \subsection[iface-StrictAnal]{Interface to the outside world}
81 %************************************************************************
84 saWwTopBinds :: SplitUniqSupply
85 -> (GlobalSwitch -> Bool)
89 saWwTopBinds us switch_chker binds
91 do_all_strict = switch_chker AllStrict
93 -- mark each binder with its strictness
94 #ifndef OMIT_STRANAL_STATS
95 (binds_w_strictness, sa_stats)
96 = sa_top_binds do_all_strict binds nullSaStats
99 = sa_top_binds do_all_strict binds
102 -- possibly show what we decided about strictness...
103 (if switch_chker D_dump_stranal
104 then pprTrace "Strictness:\n" (ppAboves (
105 map (pprCoreBinding PprDebug pprBigCoreBinder pprBigCoreBinder ppr) binds_w_strictness))
108 -- possibly show how many things we marked as demanded...
109 ((if switch_chker D_simplifier_stats
110 #ifndef OMIT_STRANAL_STATS
111 then pp_stats sa_stats
117 -- create worker/wrappers, and mark binders with their
118 -- "strictness info" [which encodes their
119 -- worker/wrapper-ness]
120 (workersAndWrappers binds_w_strictness us switch_chker))
121 #ifndef OMIT_STRANAL_STATS
123 pp_stats (SaStats tlam dlam tc dc tlet dlet)
124 = pprTrace "Binders marked demanded: "
125 (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
126 ppStr "; Case vars: ", ppInt IBOX(dc), ppChar '/', ppInt IBOX(tc),
127 ppStr "; Let vars: ", ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet)
132 %************************************************************************
134 \subsection[saBinds]{Strictness analysis of bindings}
136 %************************************************************************
138 [Some of the documentation about types, etc., in \tr{SaLib} may be
139 helpful for understanding this module.]
141 @saTopBinds@ tags each binder in the program with its @Demand@.
142 That tells how each binder is {\em used}; if @Strict@, then the binder
143 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
144 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
146 (The above info is actually recorded for posterity in each binder's
147 IdInfo, notably its @DemandInfo@.)
149 We proceed by analysing the bindings top-to-bottom, building up an
150 environment which maps @Id@s to their abstract values (i.e., an
151 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
154 saTopBinds :: Bool -> [PlainCoreBinding] -> [PlainCoreBinding] -- exported
155 sa_top_binds :: Bool -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
157 saTopBinds do_all_strict binds
158 #ifndef OMIT_STRANAL_STATS
159 = fst (sa_top_binds do_all_strict binds nullSaStats)
161 = sa_top_binds do_all_strict binds
164 sa_top_binds do_all_strict binds
165 = do_it (nullAbsValEnv do_all_strict) (nullAbsValEnv False) binds
167 do_it _ _ [] = returnSa []
168 do_it senv aenv (b:bs)
169 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
170 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
171 returnSa (new_b : new_bs)
174 @saTopBind@ is only used for the top level. We don't add any demand
175 info to these ids because we can't work it out. In any case, it
176 doesn't do us any good to know whether top-level binders are sure to
177 be used; we can't turn top-level @let@s into @case@s.
180 saTopBind :: StrictEnv -> AbsenceEnv
182 -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding)
184 saTopBind str_env abs_env (CoNonRec binder rhs)
185 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
187 str_rhs = absEval StrAnal rhs str_env
188 abs_rhs = absEval AbsAnal rhs abs_env
190 widened_str_rhs = widen StrAnal str_rhs
191 widened_abs_rhs = widen AbsAnal abs_rhs
192 -- The widening above is done for efficiency reasons.
193 -- See notes on CoLet case in SaAbsInt.lhs
195 new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs
199 -- Augment environments with a mapping of the
200 -- binder to its abstract values, computed by absEval
201 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
202 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
204 returnSa (new_str_env, new_abs_env, CoNonRec new_binder new_rhs)
206 saTopBind str_env abs_env (CoRec pairs)
208 (binders,rhss) = unzip pairs
209 str_rhss = fixpoint StrAnal binders rhss str_env
210 abs_rhss = fixpoint AbsAnal binders rhss abs_env
211 -- fixpoint returns widened values
212 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
213 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
214 new_binders = zipWith4 addStrictnessInfoToId 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, CoRec 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 -> PlainCoreExpr -> SaM PlainCoreExpr
235 saExpr _ _ e@(CoVar _) = returnSa e
236 saExpr _ _ e@(CoLit _) = returnSa e
237 saExpr _ _ e@(CoCon _ _ _) = returnSa e
238 saExpr _ _ e@(CoPrim _ _ _) = returnSa e
240 saExpr str_env abs_env (CoLam args body)
241 = saExpr str_env abs_env body `thenSa` \ new_body ->
243 new_args = addDemandInfoToIds str_env abs_env body args
245 tickLambdas new_args `thenSa_` -- stats
246 returnSa (CoLam new_args 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 (CoApp fun arg)
253 = saExpr str_env abs_env fun `thenSa` \ new_fun ->
254 returnSa (CoApp 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 (CoSCC cc expr)
261 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
262 returnSa (CoSCC cc new_expr)
264 saExpr str_env abs_env (CoCase expr (CoAlgAlts 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 (CoCase new_expr (CoAlgAlts 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 (CoCase expr (CoPrimAlts 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 (CoCase new_expr (CoPrimAlts 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 (CoLet (CoNonRec binder rhs) body)
289 = -- Analyse the RHS in the environment at hand
290 saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
292 -- Bind this binder to the abstract value of the RHS; analyse
293 -- the body of the `let' in the extended environment.
294 str_rhs_val = absEval StrAnal rhs str_env
295 abs_rhs_val = absEval AbsAnal rhs abs_env
297 widened_str_rhs = widen StrAnal str_rhs_val
298 widened_abs_rhs = widen AbsAnal abs_rhs_val
299 -- The widening above is done for efficiency reasons.
300 -- See notes on CoLet case in SaAbsInt.lhs
302 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
303 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
305 -- Now determine the strictness of this binder; use that info
306 -- to record DemandInfo/StrictnessInfo in the binder.
307 new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs
308 (addDemandInfoToId str_env abs_env body binder)
311 tickLet new_binder `thenSa_` -- stats
312 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
313 returnSa (CoLet (CoNonRec new_binder new_rhs) new_body)
315 saExpr str_env abs_env (CoLet (CoRec pairs) body)
317 (binders,rhss) = unzip pairs
318 str_vals = fixpoint StrAnal binders rhss str_env
319 abs_vals = fixpoint AbsAnal binders rhss abs_env
320 -- fixpoint returns widened values
321 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
322 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
324 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
325 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
327 -- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
328 -- DON'T add demand info in a CoRec!
329 -- a) it's useless: we can't do let-to-case
330 -- b) it's incorrect. Consider
331 -- letrec x = ...y...
334 -- When we ask whether y is demanded we'll bind y to bottom and
335 -- evaluate the body of the letrec. But that will result in our
336 -- deciding that y is absent, which is plain wrong!
337 -- It's much easier simply not to do this.
339 improved_binders = zipWith4 addStrictnessInfoToId str_vals abs_vals binders rhss
340 whiter_than_white_binders = launder improved_binders
342 new_pairs = whiter_than_white_binders `zip` new_rhss
344 returnSa (CoLet (CoRec new_pairs) new_body)
346 launder me = {-still-} me
350 saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault
352 saDefault str_env abs_env (CoBindDefault bdr rhs)
353 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
355 new_bdr = addDemandInfoToId str_env abs_env rhs bdr
357 tickCases [new_bdr] `thenSa_` -- stats
358 returnSa (CoBindDefault new_bdr new_rhs)
362 %************************************************************************
364 \subsection[computeInfos]{Add computed info to binders}
366 %************************************************************************
368 Important note (Sept 93). @addStrictnessInfoToId@ is used only for let(rec)
369 bound variables, and is use to attach the strictness (not demand) info
370 to the binder. We are careful to restrict this strictness info to the
371 lambda-bound arguments which are actually visible, at the top level,
372 lest we accidentally lose laziness by eagerly looking for an "extra" argument.
373 So we "dig for lambdas" in a rather syntactic way.
375 A better idea might be to have some kind of arity analysis to
376 tell how many args could safely be grabbed.
379 addStrictnessInfoToId
380 :: AbsVal -- Abstract strictness value
381 -> AbsVal -- Ditto absence
383 -> PlainCoreExpr -- Its RHS
384 -> Id -- Augmented with strictness
386 addStrictnessInfoToId str_val abs_val binder body
387 = if isWrapperId binder then
388 binder -- Avoid clobbering existing strictness info
389 -- (and, more importantly, worker info).
390 -- Deeply suspicious (SLPJ)
392 if (isBot str_val) then
393 binder `addIdStrictness` mkBottomStrictnessInfo
395 case (digForLambdas body) of { (_, lambda_bounds, rhs) ->
397 tys = map getIdUniType lambda_bounds
398 strictness = findStrictness tys str_val abs_val
400 binder `addIdStrictness` mkStrictnessInfo strictness Nothing
405 addDemandInfoToId :: StrictEnv -> AbsenceEnv
406 -> PlainCoreExpr -- The scope of the id
408 -> Id -- Id augmented with Demand info
410 addDemandInfoToId str_env abs_env expr binder
411 = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
413 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> [Id] -> [Id]
415 addDemandInfoToIds str_env abs_env expr binders
416 = map (addDemandInfoToId str_env abs_env expr) binders
419 %************************************************************************
421 \subsection{Monad used herein for stats}
423 %************************************************************************
427 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
428 FAST_INT FAST_INT -- total/marked-demanded case-bound
429 FAST_INT FAST_INT -- total/marked-demanded let-bound
430 -- (excl. top-level; excl. letrecs)
432 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
434 thenSa :: SaM a -> (a -> SaM b) -> SaM b
435 thenSa_ :: SaM a -> SaM b -> SaM b
436 returnSa :: a -> SaM a
438 #ifdef __GLASGOW_HASKELL__
439 {-# INLINE thenSa #-}
440 {-# INLINE thenSa_ #-}
441 {-# INLINE returnSa #-}
444 tickLambdas :: [Id] -> SaM ()
445 tickCases :: [Id] -> SaM ()
446 tickLet :: Id -> SaM ()
448 #ifndef OMIT_STRANAL_STATS
449 type SaM a = SaStats -> (a, SaStats)
451 thenSa expr cont stats
452 = case (expr stats) of { (result, stats1) ->
455 thenSa_ expr cont stats
456 = case (expr stats) of { (_, stats1) ->
459 returnSa x stats = (x, stats)
461 tickLambdas vars (SaStats tlam dlam tc dc tlet dlet)
462 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
463 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
465 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
466 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
467 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
469 tickLet var (SaStats tlam dlam tc dc tlet dlet)
470 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
471 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
473 tick_demanded var (tot, demanded)
475 if (willBeDemanded (getIdDemandInfo var))
479 #else {-OMIT_STRANAL_STATS-}
483 thenSa expr cont = cont expr
485 thenSa_ expr cont = cont
489 tickLambdas vars = panic "OMIT_STRANAL_STATS: tickLambdas"
490 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
491 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
493 #endif {-OMIT_STRANAL_STATS-}
495 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
497 mapSa f [] = returnSa []
499 = f x `thenSa` \ r ->
500 mapSa f xs `thenSa` \ rs ->