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, isWrapperId,
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 )
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
92 strflags = (opt_AllStrict, opt_NumbersStrict)
94 -- mark each binder with its strictness
95 #ifndef OMIT_STRANAL_STATS
96 (binds_w_strictness, sa_stats)
97 = sa_top_binds strflags binds nullSaStats
100 = sa_top_binds strflags binds
103 -- possibly show what we decided about strictness...
104 (if opt_D_dump_stranal
105 then pprTrace "Strictness:\n" (ppAboves (
106 map (pprCoreBinding PprDebug) binds_w_strictness))
109 -- possibly show how many things we marked as demanded...
110 ((if opt_D_simplifier_stats
111 #ifndef OMIT_STRANAL_STATS
112 then pp_stats sa_stats
118 -- create worker/wrappers, and mark binders with their
119 -- "strictness info" [which encodes their
120 -- worker/wrapper-ness]
121 (workersAndWrappers binds_w_strictness us))
122 #ifndef OMIT_STRANAL_STATS
124 pp_stats (SaStats tlam dlam tc dc tlet dlet)
125 = pprTrace "Binders marked demanded: "
126 (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam),
127 ppStr "; Case vars: ", ppInt IBOX(dc), ppChar '/', ppInt IBOX(tc),
128 ppStr "; Let vars: ", ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet)
133 %************************************************************************
135 \subsection[saBinds]{Strictness analysis of bindings}
137 %************************************************************************
139 [Some of the documentation about types, etc., in \tr{SaLib} may be
140 helpful for understanding this module.]
142 @saTopBinds@ tags each binder in the program with its @Demand@.
143 That tells how each binder is {\em used}; if @Strict@, then the binder
144 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
145 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
147 (The above info is actually recorded for posterity in each binder's
148 IdInfo, notably its @DemandInfo@.)
150 We proceed by analysing the bindings top-to-bottom, building up an
151 environment which maps @Id@s to their abstract values (i.e., an
152 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
155 saTopBinds :: StrAnalFlags -> [CoreBinding] -> [CoreBinding] -- exported
156 sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported
158 saTopBinds strflags binds
159 #ifndef OMIT_STRANAL_STATS
160 = fst (sa_top_binds strflags binds nullSaStats)
162 = sa_top_binds strflags binds
165 sa_top_binds strflags binds
167 starting_abs_env = nullAbsValEnv strflags
169 do_it starting_abs_env starting_abs_env binds
171 do_it _ _ [] = returnSa []
172 do_it senv aenv (b:bs)
173 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
174 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
175 returnSa (new_b : new_bs)
178 @saTopBind@ is only used for the top level. We don't add any demand
179 info to these ids because we can't work it out. In any case, it
180 doesn't do us any good to know whether top-level binders are sure to
181 be used; we can't turn top-level @let@s into @case@s.
184 saTopBind :: StrictEnv -> AbsenceEnv
186 -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
188 saTopBind str_env abs_env (NonRec binder rhs)
189 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
191 strflags = getStrAnalFlags str_env
193 str_rhs = absEval StrAnal rhs str_env
194 abs_rhs = absEval AbsAnal rhs abs_env
196 widened_str_rhs = widen StrAnal str_rhs
197 widened_abs_rhs = widen AbsAnal abs_rhs
198 -- The widening above is done for efficiency reasons.
199 -- See notes on Let case in SaAbsInt.lhs
202 = addStrictnessInfoToId
204 widened_str_rhs widened_abs_rhs
208 -- Augment environments with a mapping of the
209 -- binder to its abstract values, computed by absEval
210 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
211 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
213 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
215 saTopBind str_env abs_env (Rec pairs)
217 strflags = getStrAnalFlags str_env
218 (binders,rhss) = unzip pairs
219 str_rhss = fixpoint StrAnal binders rhss str_env
220 abs_rhss = fixpoint AbsAnal binders rhss abs_env
221 -- fixpoint returns widened values
222 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
223 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
224 new_binders = zipWith4Equal "saTopBind" (addStrictnessInfoToId strflags)
225 str_rhss abs_rhss binders rhss
227 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
229 new_pairs = new_binders `zip` new_rhss
231 returnSa (new_str_env, new_abs_env, Rec new_pairs)
234 %************************************************************************
236 \subsection[saExpr]{Strictness analysis of an expression}
238 %************************************************************************
240 @saExpr@ computes the strictness of an expression within a given
244 saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
246 saExpr _ _ e@(Var _) = returnSa e
247 saExpr _ _ e@(Lit _) = returnSa e
248 saExpr _ _ e@(Con _ _) = returnSa e
249 saExpr _ _ e@(Prim _ _) = returnSa e
251 saExpr str_env abs_env (Lam (ValBinder arg) body)
252 = saExpr str_env abs_env body `thenSa` \ new_body ->
254 new_arg = addDemandInfoToId str_env abs_env body arg
256 tickLambda new_arg `thenSa_` -- stats
257 returnSa (Lam (ValBinder new_arg) new_body)
259 saExpr str_env abs_env (Lam other_binder expr)
260 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
261 returnSa (Lam other_binder new_expr)
263 saExpr str_env abs_env (App fun arg)
264 = saExpr str_env abs_env fun `thenSa` \ new_fun ->
265 returnSa (App new_fun arg)
267 saExpr str_env abs_env (SCC cc expr)
268 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
269 returnSa (SCC cc new_expr)
271 saExpr str_env abs_env (Coerce c ty expr)
272 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
273 returnSa (Coerce c ty new_expr)
275 saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
276 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
277 saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
278 mapSa sa_alt alts `thenSa` \ new_alts ->
279 returnSa (Case new_expr (AlgAlts new_alts new_deflt))
281 sa_alt (con, binders, rhs)
282 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
284 new_binders = addDemandInfoToIds str_env abs_env rhs binders
286 tickCases new_binders `thenSa_` -- stats
287 returnSa (con, new_binders, new_rhs)
289 saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
290 = saExpr str_env abs_env expr `thenSa` \ new_expr ->
291 saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
292 mapSa sa_alt alts `thenSa` \ new_alts ->
293 returnSa (Case new_expr (PrimAlts new_alts new_deflt))
296 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
297 returnSa (lit, new_rhs)
299 saExpr str_env abs_env (Let (NonRec binder rhs) body)
300 = -- Analyse the RHS in the environment at hand
301 saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
303 strflags = getStrAnalFlags str_env
305 -- Bind this binder to the abstract value of the RHS; analyse
306 -- the body of the `let' in the extended environment.
307 str_rhs_val = absEval StrAnal rhs str_env
308 abs_rhs_val = absEval AbsAnal rhs abs_env
310 widened_str_rhs = widen StrAnal str_rhs_val
311 widened_abs_rhs = widen AbsAnal abs_rhs_val
312 -- The widening above is done for efficiency reasons.
313 -- See notes on Let case in SaAbsInt.lhs
315 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
316 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
318 -- Now determine the strictness of this binder; use that info
319 -- to record DemandInfo/StrictnessInfo in the binder.
320 new_binder = addStrictnessInfoToId strflags
321 widened_str_rhs widened_abs_rhs
322 (addDemandInfoToId str_env abs_env body binder)
325 tickLet new_binder `thenSa_` -- stats
326 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
327 returnSa (Let (NonRec new_binder new_rhs) new_body)
329 saExpr str_env abs_env (Let (Rec pairs) body)
331 strflags = getStrAnalFlags str_env
332 (binders,rhss) = unzip pairs
333 str_vals = fixpoint StrAnal binders rhss str_env
334 abs_vals = fixpoint AbsAnal binders rhss abs_env
335 -- fixpoint returns widened values
336 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
337 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
339 saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
340 mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
342 -- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
343 -- DON'T add demand info in a Rec!
344 -- a) it's useless: we can't do let-to-case
345 -- b) it's incorrect. Consider
346 -- letrec x = ...y...
349 -- When we ask whether y is demanded we'll bind y to bottom and
350 -- evaluate the body of the letrec. But that will result in our
351 -- deciding that y is absent, which is plain wrong!
352 -- It's much easier simply not to do this.
354 improved_binders = zipWith4Equal "saExpr" (addStrictnessInfoToId strflags)
355 str_vals abs_vals binders rhss
357 whiter_than_white_binders = launder improved_binders
359 new_pairs = whiter_than_white_binders `zip` new_rhss
361 returnSa (Let (Rec new_pairs) new_body)
363 launder me = {-still-} me
367 saDefault str_env abs_env NoDefault = returnSa NoDefault
369 saDefault str_env abs_env (BindDefault bdr rhs)
370 = saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
372 new_bdr = addDemandInfoToId str_env abs_env rhs bdr
374 tickCases [new_bdr] `thenSa_` -- stats
375 returnSa (BindDefault new_bdr new_rhs)
379 %************************************************************************
381 \subsection[computeInfos]{Add computed info to binders}
383 %************************************************************************
385 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
386 let(rec) bound variables, and is use to attach the strictness (not
387 demand) info to the binder. We are careful to restrict this
388 strictness info to the lambda-bound arguments which are actually
389 visible, at the top level, lest we accidentally lose laziness by
390 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
391 rather syntactic way.
393 A better idea might be to have some kind of arity analysis to
394 tell how many args could safely be grabbed.
397 addStrictnessInfoToId
399 -> AbsVal -- Abstract strictness value
400 -> AbsVal -- Ditto absence
402 -> CoreExpr -- Its RHS
403 -> Id -- Augmented with strictness
405 addStrictnessInfoToId strflags str_val abs_val binder body
406 = if isWrapperId binder then
407 binder -- Avoid clobbering existing strictness info
408 -- (and, more importantly, worker info).
409 -- Deeply suspicious (SLPJ)
411 if (isBot str_val) then
412 binder `addIdStrictness` mkBottomStrictnessInfo
414 case (collectBinders body) of { (_, _, lambda_bounds, rhs) ->
416 tys = map idType lambda_bounds
417 strictness = findStrictness strflags tys str_val abs_val
419 binder `addIdStrictness` mkStrictnessInfo strictness Nothing
424 addDemandInfoToId :: StrictEnv -> AbsenceEnv
425 -> CoreExpr -- The scope of the id
427 -> Id -- Id augmented with Demand info
429 addDemandInfoToId str_env abs_env expr binder
430 = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
432 addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
434 addDemandInfoToIds str_env abs_env expr binders
435 = map (addDemandInfoToId str_env abs_env expr) binders
438 %************************************************************************
440 \subsection{Monad used herein for stats}
442 %************************************************************************
446 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
447 FAST_INT FAST_INT -- total/marked-demanded case-bound
448 FAST_INT FAST_INT -- total/marked-demanded let-bound
449 -- (excl. top-level; excl. letrecs)
451 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
453 thenSa :: SaM a -> (a -> SaM b) -> SaM b
454 thenSa_ :: SaM a -> SaM b -> SaM b
455 returnSa :: a -> SaM a
457 {-# INLINE thenSa #-}
458 {-# INLINE thenSa_ #-}
459 {-# INLINE returnSa #-}
461 tickLambda :: Id -> SaM ()
462 tickCases :: [Id] -> SaM ()
463 tickLet :: Id -> SaM ()
465 #ifndef OMIT_STRANAL_STATS
466 type SaM a = SaStats -> (a, SaStats)
468 thenSa expr cont stats
469 = case (expr stats) of { (result, stats1) ->
472 thenSa_ expr cont stats
473 = case (expr stats) of { (_, stats1) ->
476 returnSa x stats = (x, stats)
478 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
479 = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
480 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
482 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
483 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
484 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
486 tickLet var (SaStats tlam dlam tc dc tlet dlet)
487 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
488 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
490 tick_demanded var (tot, demanded)
492 if (willBeDemanded (getIdDemandInfo var))
496 #else {-OMIT_STRANAL_STATS-}
500 thenSa expr cont = cont expr
502 thenSa_ expr cont = cont
506 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
507 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
508 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
510 #endif {-OMIT_STRANAL_STATS-}
512 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
514 mapSa f [] = returnSa []
516 = f x `thenSa` \ r ->
517 mapSa f xs `thenSa` \ rs ->