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 strflags = (switch_chker AllStrict, switch_chker NumbersStrict)
93 -- mark each binder with its strictness
94 #ifndef OMIT_STRANAL_STATS
95 (binds_w_strictness, sa_stats)
96 = sa_top_binds strflags binds nullSaStats
99 = sa_top_binds strflags 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 :: StrAnalFlags -> [PlainCoreBinding] -> [PlainCoreBinding] -- exported
155 sa_top_binds :: StrAnalFlags -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
157 saTopBinds strflags binds
158 #ifndef OMIT_STRANAL_STATS
159 = fst (sa_top_binds strflags binds nullSaStats)
161 = sa_top_binds strflags binds
164 sa_top_binds strflags binds
166 starting_abs_env = nullAbsValEnv strflags
168 do_it starting_abs_env starting_abs_env binds
170 do_it _ _ [] = returnSa []
171 do_it senv aenv (b:bs)
172 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
173 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
174 returnSa (new_b : new_bs)
177 @saTopBind@ is only used for the top level. We don't add any demand
178 info to these ids because we can't work it out. In any case, it
179 doesn't do us any good to know whether top-level binders are sure to
180 be used; we can't turn top-level @let@s into @case@s.
183 saTopBind :: StrictEnv -> AbsenceEnv
185 -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding)
187 saTopBind str_env abs_env (CoNonRec binder rhs)
188 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
190 strflags = getStrAnalFlags str_env
192 str_rhs = absEval StrAnal rhs str_env
193 abs_rhs = absEval AbsAnal rhs abs_env
195 widened_str_rhs = widen StrAnal str_rhs
196 widened_abs_rhs = widen AbsAnal abs_rhs
197 -- The widening above is done for efficiency reasons.
198 -- See notes on CoLet case in SaAbsInt.lhs
201 = addStrictnessInfoToId
203 widened_str_rhs widened_abs_rhs
207 -- Augment environments with a mapping of the
208 -- binder to its abstract values, computed by absEval
209 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
210 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
212 returnSa (new_str_env, new_abs_env, CoNonRec new_binder new_rhs)
214 saTopBind str_env abs_env (CoRec pairs)
216 strflags = getStrAnalFlags str_env
217 (binders,rhss) = unzip pairs
218 str_rhss = fixpoint StrAnal binders rhss str_env
219 abs_rhss = fixpoint AbsAnal binders rhss abs_env
220 -- fixpoint returns widened values
221 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
222 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
223 new_binders = zipWith4 (addStrictnessInfoToId strflags)
224 str_rhss abs_rhss binders rhss
226 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
228 new_pairs = new_binders `zip` new_rhss
230 returnSa (new_str_env, new_abs_env, CoRec new_pairs)
233 %************************************************************************
235 \subsection[saExpr]{Strictness analysis of an expression}
237 %************************************************************************
239 @saExpr@ computes the strictness of an expression within a given
243 saExpr :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> SaM PlainCoreExpr
245 saExpr _ _ e@(CoVar _) = returnSa e
246 saExpr _ _ e@(CoLit _) = returnSa e
247 saExpr _ _ e@(CoCon _ _ _) = returnSa e
248 saExpr _ _ e@(CoPrim _ _ _) = returnSa e
250 saExpr str_env abs_env (CoLam args body)
251 = saExpr str_env abs_env body `thenSa` \ new_body ->
253 new_args = addDemandInfoToIds str_env abs_env body args
255 tickLambdas new_args `thenSa_` -- stats
256 returnSa (CoLam new_args new_body)
258 saExpr str_env abs_env (CoTyLam ty expr)
259 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
260 returnSa (CoTyLam ty new_expr)
262 saExpr str_env abs_env (CoApp fun arg)
263 = saExpr str_env abs_env fun `thenSa` \ new_fun ->
264 returnSa (CoApp new_fun arg)
266 saExpr str_env abs_env (CoTyApp expr ty)
267 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
268 returnSa (CoTyApp new_expr ty)
270 saExpr str_env abs_env (CoSCC cc expr)
271 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
272 returnSa (CoSCC cc new_expr)
274 saExpr str_env abs_env (CoCase expr (CoAlgAlts alts deflt))
275 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
276 saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
277 mapSa sa_alt alts `thenSa` \ new_alts ->
278 returnSa (CoCase new_expr (CoAlgAlts new_alts new_deflt))
280 sa_alt (con, binders, rhs)
281 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
283 new_binders = addDemandInfoToIds str_env abs_env rhs binders
285 tickCases new_binders `thenSa_` -- stats
286 returnSa (con, new_binders, new_rhs)
288 saExpr str_env abs_env (CoCase expr (CoPrimAlts alts deflt))
289 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
290 saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
291 mapSa sa_alt alts `thenSa` \ new_alts ->
292 returnSa (CoCase new_expr (CoPrimAlts new_alts new_deflt))
295 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
296 returnSa (lit, new_rhs)
298 saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body)
299 = -- Analyse the RHS in the environment at hand
300 saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
302 strflags = getStrAnalFlags str_env
304 -- Bind this binder to the abstract value of the RHS; analyse
305 -- the body of the `let' in the extended environment.
306 str_rhs_val = absEval StrAnal rhs str_env
307 abs_rhs_val = absEval AbsAnal rhs abs_env
309 widened_str_rhs = widen StrAnal str_rhs_val
310 widened_abs_rhs = widen AbsAnal abs_rhs_val
311 -- The widening above is done for efficiency reasons.
312 -- See notes on CoLet case in SaAbsInt.lhs
314 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
315 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
317 -- Now determine the strictness of this binder; use that info
318 -- to record DemandInfo/StrictnessInfo in the binder.
319 new_binder = addStrictnessInfoToId strflags
320 widened_str_rhs widened_abs_rhs
321 (addDemandInfoToId str_env abs_env body binder)
324 tickLet new_binder `thenSa_` -- stats
325 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
326 returnSa (CoLet (CoNonRec new_binder new_rhs) new_body)
328 saExpr str_env abs_env (CoLet (CoRec pairs) body)
330 strflags = getStrAnalFlags str_env
331 (binders,rhss) = unzip pairs
332 str_vals = fixpoint StrAnal binders rhss str_env
333 abs_vals = fixpoint AbsAnal binders rhss abs_env
334 -- fixpoint returns widened values
335 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
336 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
338 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
339 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
341 -- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
342 -- DON'T add demand info in a CoRec!
343 -- a) it's useless: we can't do let-to-case
344 -- b) it's incorrect. Consider
345 -- letrec x = ...y...
348 -- When we ask whether y is demanded we'll bind y to bottom and
349 -- evaluate the body of the letrec. But that will result in our
350 -- deciding that y is absent, which is plain wrong!
351 -- It's much easier simply not to do this.
353 improved_binders = zipWith4 (addStrictnessInfoToId strflags)
354 str_vals abs_vals binders rhss
356 whiter_than_white_binders = launder improved_binders
358 new_pairs = whiter_than_white_binders `zip` new_rhss
360 returnSa (CoLet (CoRec new_pairs) new_body)
362 launder me = {-still-} me
366 saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault
368 saDefault str_env abs_env (CoBindDefault bdr rhs)
369 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
371 new_bdr = addDemandInfoToId str_env abs_env rhs bdr
373 tickCases [new_bdr] `thenSa_` -- stats
374 returnSa (CoBindDefault new_bdr new_rhs)
378 %************************************************************************
380 \subsection[computeInfos]{Add computed info to binders}
382 %************************************************************************
384 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
385 let(rec) bound variables, and is use to attach the strictness (not
386 demand) info to the binder. We are careful to restrict this
387 strictness info to the lambda-bound arguments which are actually
388 visible, at the top level, lest we accidentally lose laziness by
389 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
390 rather syntactic way.
392 A better idea might be to have some kind of arity analysis to
393 tell how many args could safely be grabbed.
396 addStrictnessInfoToId
398 -> AbsVal -- Abstract strictness value
399 -> AbsVal -- Ditto absence
401 -> PlainCoreExpr -- Its RHS
402 -> Id -- Augmented with strictness
404 addStrictnessInfoToId strflags str_val abs_val binder body
405 = if isWrapperId binder then
406 binder -- Avoid clobbering existing strictness info
407 -- (and, more importantly, worker info).
408 -- Deeply suspicious (SLPJ)
410 if (isBot str_val) then
411 binder `addIdStrictness` mkBottomStrictnessInfo
413 case (digForLambdas body) of { (_, lambda_bounds, rhs) ->
415 tys = map getIdUniType lambda_bounds
416 strictness = findStrictness strflags tys str_val abs_val
418 binder `addIdStrictness` mkStrictnessInfo strictness Nothing
423 addDemandInfoToId :: StrictEnv -> AbsenceEnv
424 -> PlainCoreExpr -- The scope of the id
426 -> Id -- Id augmented with Demand info
428 addDemandInfoToId str_env abs_env expr binder
429 = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
431 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> [Id] -> [Id]
433 addDemandInfoToIds str_env abs_env expr binders
434 = map (addDemandInfoToId str_env abs_env expr) binders
437 %************************************************************************
439 \subsection{Monad used herein for stats}
441 %************************************************************************
445 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
446 FAST_INT FAST_INT -- total/marked-demanded case-bound
447 FAST_INT FAST_INT -- total/marked-demanded let-bound
448 -- (excl. top-level; excl. letrecs)
450 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
452 thenSa :: SaM a -> (a -> SaM b) -> SaM b
453 thenSa_ :: SaM a -> SaM b -> SaM b
454 returnSa :: a -> SaM a
456 #ifdef __GLASGOW_HASKELL__
457 {-# INLINE thenSa #-}
458 {-# INLINE thenSa_ #-}
459 {-# INLINE returnSa #-}
462 tickLambdas :: [Id] -> SaM ()
463 tickCases :: [Id] -> SaM ()
464 tickLet :: Id -> SaM ()
466 #ifndef OMIT_STRANAL_STATS
467 type SaM a = SaStats -> (a, SaStats)
469 thenSa expr cont stats
470 = case (expr stats) of { (result, stats1) ->
473 thenSa_ expr cont stats
474 = case (expr stats) of { (_, stats1) ->
477 returnSa x stats = (x, stats)
479 tickLambdas vars (SaStats tlam dlam tc dc tlet dlet)
480 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
481 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
483 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
484 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
485 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
487 tickLet var (SaStats tlam dlam tc dc tlet dlet)
488 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
489 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
491 tick_demanded var (tot, demanded)
493 if (willBeDemanded (getIdDemandInfo var))
497 #else {-OMIT_STRANAL_STATS-}
501 thenSa expr cont = cont expr
503 thenSa_ expr cont = cont
507 tickLambdas vars = panic "OMIT_STRANAL_STATS: tickLambdas"
508 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
509 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
511 #endif {-OMIT_STRANAL_STATS-}
513 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
515 mapSa f [] = returnSa []
517 = f x `thenSa` \ r ->
518 mapSa f xs `thenSa` \ rs ->