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
16 import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict,
17 opt_D_dump_stranal, opt_D_simplifier_stats
20 import Id ( idType, addIdStrictness,
21 getIdDemandInfo, addIdDemandInfo,
22 GenId{-instance Outputable-}
24 import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo,
25 mkDemandInfo, willBeDemanded, DemandInfo
27 import PprCore ( pprCoreBinding, pprBigCoreBinder )
28 import PprStyle ( PprStyle(..) )
29 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
30 import Pretty ( ppBesides, ppStr, ppInt, ppChar, ppAboves )
33 import TyVar ( GenTyVar{-instance Eq-} )
34 import WorkWrap -- "back-end" of strictness analyser
35 import Unique ( Unique{-instance Eq -} )
36 import Util ( zipWith4Equal, pprTrace, panic{-ToDo:rm-} )
38 isWrapperId = panic "StrictAnal.isWrapperId (ToDo)"
42 %************************************************************************
44 \subsection[Thoughts]{Random thoughts}
46 %************************************************************************
48 A note about worker-wrappering. If we have
51 f = let v = <expensive>
54 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
56 f = \x -> case x of Int x# -> fw x#
57 fw = \x# -> let x = Int x#
62 because this obviously loses laziness, since now <expensive>
63 is done each time. Alas.
65 WATCH OUT! This can mean that something is unboxed only to be
66 boxed again. For example
70 Here g is strict, and *will* split into worker-wrapper. A call to
71 g, with the wrapper inlined will then be
73 case arg of Int a# -> gw a#
75 Now g calls f, which has no wrapper, so it has to box it.
77 gw = \a# -> f (Int a#)
82 %************************************************************************
84 \subsection[iface-StrictAnal]{Interface to the outside world}
86 %************************************************************************
89 saWwTopBinds :: UniqSupply
95 strflags = (opt_AllStrict, opt_NumbersStrict)
97 -- mark each binder with its strictness
98 #ifndef OMIT_STRANAL_STATS
99 (binds_w_strictness, sa_stats)
100 = sa_top_binds strflags binds nullSaStats
103 = sa_top_binds strflags binds
106 -- possibly show what we decided about strictness...
107 (if opt_D_dump_stranal
108 then pprTrace "Strictness:\n" (ppAboves (
109 map (pprCoreBinding PprDebug) binds_w_strictness))
112 -- possibly show how many things we marked as demanded...
113 ((if opt_D_simplifier_stats
114 #ifndef OMIT_STRANAL_STATS
115 then pp_stats sa_stats
121 -- create worker/wrappers, and mark binders with their
122 -- "strictness info" [which encodes their
123 -- worker/wrapper-ness]
124 (workersAndWrappers binds_w_strictness us))
125 #ifndef OMIT_STRANAL_STATS
127 pp_stats (SaStats tlam dlam tc dc tlet dlet)
128 = pprTrace "Binders marked demanded: "
129 (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
130 ppStr "; Case vars: ", ppInt IBOX(dc), ppChar '/', ppInt IBOX(tc),
131 ppStr "; Let vars: ", ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet)
136 %************************************************************************
138 \subsection[saBinds]{Strictness analysis of bindings}
140 %************************************************************************
142 [Some of the documentation about types, etc., in \tr{SaLib} may be
143 helpful for understanding this module.]
145 @saTopBinds@ tags each binder in the program with its @Demand@.
146 That tells how each binder is {\em used}; if @Strict@, then the binder
147 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
148 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
150 (The above info is actually recorded for posterity in each binder's
151 IdInfo, notably its @DemandInfo@.)
153 We proceed by analysing the bindings top-to-bottom, building up an
154 environment which maps @Id@s to their abstract values (i.e., an
155 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
158 saTopBinds :: StrAnalFlags -> [CoreBinding] -> [CoreBinding] -- exported
159 sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported
161 saTopBinds strflags binds
162 #ifndef OMIT_STRANAL_STATS
163 = fst (sa_top_binds strflags binds nullSaStats)
165 = sa_top_binds strflags binds
168 sa_top_binds strflags binds
170 starting_abs_env = nullAbsValEnv strflags
172 do_it starting_abs_env starting_abs_env binds
174 do_it _ _ [] = returnSa []
175 do_it senv aenv (b:bs)
176 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
177 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
178 returnSa (new_b : new_bs)
181 @saTopBind@ is only used for the top level. We don't add any demand
182 info to these ids because we can't work it out. In any case, it
183 doesn't do us any good to know whether top-level binders are sure to
184 be used; we can't turn top-level @let@s into @case@s.
187 saTopBind :: StrictEnv -> AbsenceEnv
189 -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
191 saTopBind str_env abs_env (NonRec binder rhs)
192 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
194 strflags = getStrAnalFlags str_env
196 str_rhs = absEval StrAnal rhs str_env
197 abs_rhs = absEval AbsAnal rhs abs_env
199 widened_str_rhs = widen StrAnal str_rhs
200 widened_abs_rhs = widen AbsAnal abs_rhs
201 -- The widening above is done for efficiency reasons.
202 -- See notes on Let case in SaAbsInt.lhs
205 = addStrictnessInfoToId
207 widened_str_rhs widened_abs_rhs
211 -- Augment environments with a mapping of the
212 -- binder to its abstract values, computed by absEval
213 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
214 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
216 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
218 saTopBind str_env abs_env (Rec pairs)
220 strflags = getStrAnalFlags str_env
221 (binders,rhss) = unzip pairs
222 str_rhss = fixpoint StrAnal binders rhss str_env
223 abs_rhss = fixpoint AbsAnal binders rhss abs_env
224 -- fixpoint returns widened values
225 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
226 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
227 new_binders = zipWith4Equal "saTopBind" (addStrictnessInfoToId strflags)
228 str_rhss abs_rhss binders rhss
230 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
232 new_pairs = new_binders `zip` new_rhss
234 returnSa (new_str_env, new_abs_env, Rec new_pairs)
237 %************************************************************************
239 \subsection[saExpr]{Strictness analysis of an expression}
241 %************************************************************************
243 @saExpr@ computes the strictness of an expression within a given
247 saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
249 saExpr _ _ e@(Var _) = returnSa e
250 saExpr _ _ e@(Lit _) = returnSa e
251 saExpr _ _ e@(Con _ _) = returnSa e
252 saExpr _ _ e@(Prim _ _) = returnSa e
254 saExpr str_env abs_env (Lam (ValBinder arg) body)
255 = saExpr str_env abs_env body `thenSa` \ new_body ->
257 new_arg = addDemandInfoToId str_env abs_env body arg
259 tickLambda new_arg `thenSa_` -- stats
260 returnSa (Lam (ValBinder new_arg) new_body)
262 saExpr str_env abs_env (Lam other_binder expr)
263 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
264 returnSa (Lam other_binder new_expr)
266 saExpr str_env abs_env (App fun arg)
267 = saExpr str_env abs_env fun `thenSa` \ new_fun ->
268 returnSa (App new_fun arg)
270 saExpr str_env abs_env (SCC cc expr)
271 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
272 returnSa (SCC cc new_expr)
274 saExpr str_env abs_env (Coerce c ty expr)
275 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
276 returnSa (Coerce c ty new_expr)
278 saExpr str_env abs_env (Case expr (AlgAlts 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 (AlgAlts new_alts new_deflt))
284 sa_alt (con, binders, rhs)
285 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
287 new_binders = addDemandInfoToIds str_env abs_env rhs binders
289 tickCases new_binders `thenSa_` -- stats
290 returnSa (con, new_binders, new_rhs)
292 saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
293 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
294 saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
295 mapSa sa_alt alts `thenSa` \ new_alts ->
296 returnSa (Case new_expr (PrimAlts new_alts new_deflt))
299 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
300 returnSa (lit, new_rhs)
302 saExpr str_env abs_env (Let (NonRec binder rhs) body)
303 = -- Analyse the RHS in the environment at hand
304 saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
306 strflags = getStrAnalFlags str_env
308 -- Bind this binder to the abstract value of the RHS; analyse
309 -- the body of the `let' in the extended environment.
310 str_rhs_val = absEval StrAnal rhs str_env
311 abs_rhs_val = absEval AbsAnal rhs abs_env
313 widened_str_rhs = widen StrAnal str_rhs_val
314 widened_abs_rhs = widen AbsAnal abs_rhs_val
315 -- The widening above is done for efficiency reasons.
316 -- See notes on Let case in SaAbsInt.lhs
318 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
319 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
321 -- Now determine the strictness of this binder; use that info
322 -- to record DemandInfo/StrictnessInfo in the binder.
323 new_binder = addStrictnessInfoToId strflags
324 widened_str_rhs widened_abs_rhs
325 (addDemandInfoToId str_env abs_env body binder)
328 tickLet new_binder `thenSa_` -- stats
329 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
330 returnSa (Let (NonRec new_binder new_rhs) new_body)
332 saExpr str_env abs_env (Let (Rec pairs) body)
334 strflags = getStrAnalFlags str_env
335 (binders,rhss) = unzip pairs
336 str_vals = fixpoint StrAnal binders rhss str_env
337 abs_vals = fixpoint AbsAnal binders rhss abs_env
338 -- fixpoint returns widened values
339 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
340 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
342 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
343 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
345 -- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
346 -- DON'T add demand info in a Rec!
347 -- a) it's useless: we can't do let-to-case
348 -- b) it's incorrect. Consider
349 -- letrec x = ...y...
352 -- When we ask whether y is demanded we'll bind y to bottom and
353 -- evaluate the body of the letrec. But that will result in our
354 -- deciding that y is absent, which is plain wrong!
355 -- It's much easier simply not to do this.
357 improved_binders = zipWith4Equal "saExpr" (addStrictnessInfoToId strflags)
358 str_vals abs_vals binders rhss
360 whiter_than_white_binders = launder improved_binders
362 new_pairs = whiter_than_white_binders `zip` new_rhss
364 returnSa (Let (Rec new_pairs) new_body)
366 launder me = {-still-} me
370 saDefault str_env abs_env NoDefault = returnSa NoDefault
372 saDefault str_env abs_env (BindDefault bdr rhs)
373 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
375 new_bdr = addDemandInfoToId str_env abs_env rhs bdr
377 tickCases [new_bdr] `thenSa_` -- stats
378 returnSa (BindDefault new_bdr new_rhs)
382 %************************************************************************
384 \subsection[computeInfos]{Add computed info to binders}
386 %************************************************************************
388 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
389 let(rec) bound variables, and is use to attach the strictness (not
390 demand) info to the binder. We are careful to restrict this
391 strictness info to the lambda-bound arguments which are actually
392 visible, at the top level, lest we accidentally lose laziness by
393 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
394 rather syntactic way.
396 A better idea might be to have some kind of arity analysis to
397 tell how many args could safely be grabbed.
400 addStrictnessInfoToId
402 -> AbsVal -- Abstract strictness value
403 -> AbsVal -- Ditto absence
405 -> CoreExpr -- Its RHS
406 -> Id -- Augmented with strictness
408 addStrictnessInfoToId strflags str_val abs_val binder body
409 = if isWrapperId binder then
410 binder -- Avoid clobbering existing strictness info
411 -- (and, more importantly, worker info).
412 -- Deeply suspicious (SLPJ)
414 if (isBot str_val) then
415 binder `addIdStrictness` mkBottomStrictnessInfo
417 case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
419 tys = map idType lambda_bounds
420 strictness = findStrictness strflags tys str_val abs_val
422 binder `addIdStrictness` mkStrictnessInfo strictness Nothing
427 addDemandInfoToId :: StrictEnv -> AbsenceEnv
428 -> CoreExpr -- The scope of the id
430 -> Id -- Id augmented with Demand info
432 addDemandInfoToId str_env abs_env expr binder
433 = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
435 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
437 addDemandInfoToIds str_env abs_env expr binders
438 = map (addDemandInfoToId str_env abs_env expr) binders
441 %************************************************************************
443 \subsection{Monad used herein for stats}
445 %************************************************************************
449 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
450 FAST_INT FAST_INT -- total/marked-demanded case-bound
451 FAST_INT FAST_INT -- total/marked-demanded let-bound
452 -- (excl. top-level; excl. letrecs)
454 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
456 thenSa :: SaM a -> (a -> SaM b) -> SaM b
457 thenSa_ :: SaM a -> SaM b -> SaM b
458 returnSa :: a -> SaM a
460 {-# INLINE thenSa #-}
461 {-# INLINE thenSa_ #-}
462 {-# INLINE returnSa #-}
464 tickLambda :: Id -> SaM ()
465 tickCases :: [Id] -> SaM ()
466 tickLet :: Id -> SaM ()
468 #ifndef OMIT_STRANAL_STATS
469 type SaM a = SaStats -> (a, SaStats)
471 thenSa expr cont stats
472 = case (expr stats) of { (result, stats1) ->
475 thenSa_ expr cont stats
476 = case (expr stats) of { (_, stats1) ->
479 returnSa x stats = (x, stats)
481 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
482 = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
483 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
485 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
486 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
487 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
489 tickLet var (SaStats tlam dlam tc dc tlet dlet)
490 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
491 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
493 tick_demanded var (tot, demanded)
495 if (willBeDemanded (getIdDemandInfo var))
499 #else {-OMIT_STRANAL_STATS-}
503 thenSa expr cont = cont expr
505 thenSa_ expr cont = cont
509 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
510 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
511 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
513 #endif {-OMIT_STRANAL_STATS-}
515 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
517 mapSa f [] = returnSa []
519 = f x `thenSa` \ r ->
520 mapSa f xs `thenSa` \ rs ->