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 ) where
16 import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats
19 import Id ( idType, addIdStrictness, isWrapperId,
20 getIdDemandInfo, addIdDemandInfo,
21 GenId{-instance Outputable-}, SYN_IE(Id)
23 import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo,
24 mkDemandInfo, willBeDemanded, DemandInfo
26 import PprCore ( pprCoreBinding, pprBigCoreBinder )
27 import Outputable ( PprStyle(..) )
28 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
29 import Pretty ( Doc, hcat, ptext, int, char, vcat )
32 import TyVar ( GenTyVar{-instance Eq-} )
33 import WorkWrap -- "back-end" of strictness analyser
34 import Unique ( Unique{-instance Eq -} )
35 import UniqSupply ( UniqSupply )
36 import Util ( zipWith4Equal, pprTrace, panic )
39 %************************************************************************
41 \subsection[Thoughts]{Random thoughts}
43 %************************************************************************
45 A note about worker-wrappering. If we have
48 f = let v = <expensive>
51 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
53 f = \x -> case x of Int x# -> fw x#
54 fw = \x# -> let x = Int x#
59 because this obviously loses laziness, since now <expensive>
60 is done each time. Alas.
62 WATCH OUT! This can mean that something is unboxed only to be
63 boxed again. For example
67 Here g is strict, and *will* split into worker-wrapper. A call to
68 g, with the wrapper inlined will then be
70 case arg of Int a# -> gw a#
72 Now g calls f, which has no wrapper, so it has to box it.
74 gw = \a# -> f (Int a#)
79 %************************************************************************
81 \subsection[iface-StrictAnal]{Interface to the outside world}
83 %************************************************************************
86 saWwTopBinds :: UniqSupply
93 -- mark each binder with its strictness
94 #ifndef OMIT_STRANAL_STATS
95 (binds_w_strictness, sa_stats)
96 = saTopBinds binds nullSaStats
99 = saTopBindsBinds binds
102 -- possibly show what we decided about strictness...
103 (if opt_D_dump_stranal
104 then pprTrace "Strictness:\n" (vcat (
105 map (pprCoreBinding PprDebug) binds_w_strictness))
108 -- possibly show how many things we marked as demanded...
109 ((if opt_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))
121 #ifndef OMIT_STRANAL_STATS
123 pp_stats (SaStats tlam dlam tc dc tlet dlet)
124 = pprTrace "Binders marked demanded: "
125 (hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
126 ptext SLIT("; Case vars: "), int IBOX(dc), char '/', int IBOX(tc),
127 ptext SLIT("; Let vars: "), int IBOX(dlet), char '/', int 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 :: [CoreBinding] -> SaM [CoreBinding] -- not exported
158 starting_abs_env = nullAbsValEnv
160 do_it starting_abs_env starting_abs_env binds
162 do_it _ _ [] = returnSa []
163 do_it senv aenv (b:bs)
164 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
165 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
166 returnSa (new_b : new_bs)
169 @saTopBind@ is only used for the top level. We don't add any demand
170 info to these ids because we can't work it out. In any case, it
171 doesn't do us any good to know whether top-level binders are sure to
172 be used; we can't turn top-level @let@s into @case@s.
175 saTopBind :: StrictEnv -> AbsenceEnv
177 -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
179 saTopBind str_env abs_env (NonRec binder rhs)
180 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
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
192 widened_str_rhs widened_abs_rhs
196 -- Augment environments with a mapping of the
197 -- binder to its abstract values, computed by absEval
198 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
199 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
201 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
203 saTopBind str_env abs_env (Rec pairs)
205 (binders,rhss) = unzip pairs
206 str_rhss = fixpoint StrAnal binders rhss str_env
207 abs_rhss = fixpoint AbsAnal binders rhss abs_env
208 -- fixpoint returns widened values
209 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
210 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
211 new_binders = zipWith4Equal "saTopBind" addStrictnessInfoToId
212 str_rhss abs_rhss binders rhss
214 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
216 new_pairs = new_binders `zip` new_rhss
218 returnSa (new_str_env, new_abs_env, Rec new_pairs)
221 %************************************************************************
223 \subsection[saExpr]{Strictness analysis of an expression}
225 %************************************************************************
227 @saExpr@ computes the strictness of an expression within a given
231 saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
233 saExpr _ _ e@(Var _) = returnSa e
234 saExpr _ _ e@(Lit _) = returnSa e
235 saExpr _ _ e@(Con _ _) = returnSa e
236 saExpr _ _ e@(Prim _ _) = returnSa e
238 saExpr str_env abs_env (Lam (ValBinder arg) body)
239 = saExpr str_env abs_env body `thenSa` \ new_body ->
241 new_arg = addDemandInfoToId str_env abs_env body arg
243 tickLambda new_arg `thenSa_` -- stats
244 returnSa (Lam (ValBinder new_arg) new_body)
246 saExpr str_env abs_env (Lam other_binder expr)
247 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
248 returnSa (Lam other_binder new_expr)
250 saExpr str_env abs_env (App fun arg)
251 = saExpr str_env abs_env fun `thenSa` \ new_fun ->
252 returnSa (App new_fun arg)
254 saExpr str_env abs_env (SCC cc expr)
255 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
256 returnSa (SCC cc new_expr)
258 saExpr str_env abs_env (Coerce c ty expr)
259 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
260 returnSa (Coerce c ty new_expr)
262 saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
263 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
264 saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
265 mapSa sa_alt alts `thenSa` \ new_alts ->
266 returnSa (Case new_expr (AlgAlts new_alts new_deflt))
268 sa_alt (con, binders, rhs)
269 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
271 new_binders = addDemandInfoToIds str_env abs_env rhs binders
273 tickCases new_binders `thenSa_` -- stats
274 returnSa (con, new_binders, new_rhs)
276 saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
277 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
278 saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
279 mapSa sa_alt alts `thenSa` \ new_alts ->
280 returnSa (Case new_expr (PrimAlts new_alts new_deflt))
283 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
284 returnSa (lit, new_rhs)
286 saExpr str_env abs_env (Let (NonRec binder rhs) body)
287 = -- Analyse the RHS in the environment at hand
288 saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
290 -- Bind this binder to the abstract value of the RHS; analyse
291 -- the body of the `let' in the extended environment.
292 str_rhs_val = absEval StrAnal rhs str_env
293 abs_rhs_val = absEval AbsAnal rhs abs_env
295 widened_str_rhs = widen StrAnal str_rhs_val
296 widened_abs_rhs = widen AbsAnal abs_rhs_val
297 -- The widening above is done for efficiency reasons.
298 -- See notes on Let case in SaAbsInt.lhs
300 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
301 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
303 -- Now determine the strictness of this binder; use that info
304 -- to record DemandInfo/StrictnessInfo in the binder.
305 new_binder = addStrictnessInfoToId
306 widened_str_rhs widened_abs_rhs
307 (addDemandInfoToId str_env abs_env body binder)
310 tickLet new_binder `thenSa_` -- stats
311 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
312 returnSa (Let (NonRec new_binder new_rhs) new_body)
314 saExpr str_env abs_env (Let (Rec pairs) body)
316 (binders,rhss) = unzip pairs
317 str_vals = fixpoint StrAnal binders rhss str_env
318 abs_vals = fixpoint AbsAnal binders rhss abs_env
319 -- fixpoint returns widened values
320 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
321 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
323 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
324 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
326 -- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
327 -- DON'T add demand info in a Rec!
328 -- a) it's useless: we can't do let-to-case
329 -- b) it's incorrect. Consider
330 -- letrec x = ...y...
333 -- When we ask whether y is demanded we'll bind y to bottom and
334 -- evaluate the body of the letrec. But that will result in our
335 -- deciding that y is absent, which is plain wrong!
336 -- It's much easier simply not to do this.
338 improved_binders = zipWith4Equal "saExpr" addStrictnessInfoToId
339 str_vals abs_vals binders rhss
341 whiter_than_white_binders = launder improved_binders
343 new_pairs = whiter_than_white_binders `zip` new_rhss
345 returnSa (Let (Rec new_pairs) new_body)
347 launder me = {-still-} me
351 saDefault str_env abs_env NoDefault = returnSa NoDefault
353 saDefault str_env abs_env (BindDefault bdr rhs)
354 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
356 new_bdr = addDemandInfoToId str_env abs_env rhs bdr
358 tickCases [new_bdr] `thenSa_` -- stats
359 returnSa (BindDefault new_bdr new_rhs)
363 %************************************************************************
365 \subsection[computeInfos]{Add computed info to binders}
367 %************************************************************************
369 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
370 let(rec) bound variables, and is use to attach the strictness (not
371 demand) info to the binder. We are careful to restrict this
372 strictness info to the lambda-bound arguments which are actually
373 visible, at the top level, lest we accidentally lose laziness by
374 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
375 rather syntactic way.
377 A better idea might be to have some kind of arity analysis to
378 tell how many args could safely be grabbed.
381 addStrictnessInfoToId
382 :: AbsVal -- Abstract strictness value
383 -> AbsVal -- Ditto absence
385 -> CoreExpr -- Its RHS
386 -> Id -- Augmented with strictness
388 addStrictnessInfoToId str_val abs_val binder body
391 = binder `addIdStrictness` mkBottomStrictnessInfo
394 = case (collectBinders body) of
395 (_, _, [], rhs) -> binder
396 (_, _, lambda_bounds, rhs) -> binder `addIdStrictness`
397 mkStrictnessInfo strictness Nothing
399 tys = map idType lambda_bounds
400 strictness = findStrictness tys str_val abs_val
404 addDemandInfoToId :: StrictEnv -> AbsenceEnv
405 -> CoreExpr -- The scope of the id
407 -> Id -- Id augmented with Demand info
409 addDemandInfoToId str_env abs_env expr binder
410 = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
412 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
414 addDemandInfoToIds str_env abs_env expr binders
415 = map (addDemandInfoToId str_env abs_env expr) binders
418 %************************************************************************
420 \subsection{Monad used herein for stats}
422 %************************************************************************
426 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
427 FAST_INT FAST_INT -- total/marked-demanded case-bound
428 FAST_INT FAST_INT -- total/marked-demanded let-bound
429 -- (excl. top-level; excl. letrecs)
431 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
433 thenSa :: SaM a -> (a -> SaM b) -> SaM b
434 thenSa_ :: SaM a -> SaM b -> SaM b
435 returnSa :: a -> SaM a
437 {-# INLINE thenSa #-}
438 {-# INLINE thenSa_ #-}
439 {-# INLINE returnSa #-}
441 tickLambda :: Id -> SaM ()
442 tickCases :: [Id] -> SaM ()
443 tickLet :: Id -> SaM ()
445 #ifndef OMIT_STRANAL_STATS
446 type SaM a = SaStats -> (a, SaStats)
448 thenSa expr cont stats
449 = case (expr stats) of { (result, stats1) ->
452 thenSa_ expr cont stats
453 = case (expr stats) of { (_, stats1) ->
456 returnSa x stats = (x, stats)
458 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
459 = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
460 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
462 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
463 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
464 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
466 tickLet var (SaStats tlam dlam tc dc tlet dlet)
467 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
468 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
470 tick_demanded var (tot, demanded)
472 if (willBeDemanded (getIdDemandInfo var))
476 #else {-OMIT_STRANAL_STATS-}
480 thenSa expr cont = cont expr
482 thenSa_ expr cont = cont
486 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
487 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
488 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
490 #endif {-OMIT_STRANAL_STATS-}
492 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
494 mapSa f [] = returnSa []
496 = f x `thenSa` \ r ->
497 mapSa f xs `thenSa` \ rs ->