2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
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 module StrictAnal ( saBinds ) where
12 #include "HsVersions.h"
14 import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
16 import Id ( setIdStrictness, setInlinePragma,
17 idDemandInfo, setIdDemandInfo, isBottomingId,
20 import IdInfo ( neverInlinePrag )
21 import CoreLint ( showPass, endPass )
22 import ErrUtils ( dumpIfSet_dyn )
25 import Demand ( Demand, wwStrict, isStrict, isLazy )
26 import Util ( zipWith3Equal, stretchZipWith )
31 %************************************************************************
33 \subsection[Thoughts]{Random thoughts}
35 %************************************************************************
37 A note about worker-wrappering. If we have
40 f = let v = <expensive>
43 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
45 f = \x -> case x of Int x# -> fw x#
46 fw = \x# -> let x = Int x#
51 because this obviously loses laziness, since now <expensive>
52 is done each time. Alas.
54 WATCH OUT! This can mean that something is unboxed only to be
55 boxed again. For example
59 Here g is strict, and *will* split into worker-wrapper. A call to
60 g, with the wrapper inlined will then be
62 case arg of Int a# -> gw a#
64 Now g calls f, which has no wrapper, so it has to box it.
66 gw = \a# -> f (Int a#)
71 %************************************************************************
73 \subsection[iface-StrictAnal]{Interface to the outside world}
75 %************************************************************************
77 @saBinds@ decorates bindings with strictness info. A later
78 worker-wrapper pass can use this info to create wrappers and
82 saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
86 showPass dflags "Strictness analysis";
88 -- Mark each binder with its strictness
89 #ifndef OMIT_STRANAL_STATS
90 let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
91 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
94 let { binds_w_strictness = saTopBindsBinds binds };
97 endPass dflags "Strictness analysis" Opt_D_dump_stranal
102 %************************************************************************
104 \subsection[saBinds]{Strictness analysis of bindings}
106 %************************************************************************
108 [Some of the documentation about types, etc., in \tr{SaLib} may be
109 helpful for understanding this module.]
111 @saTopBinds@ tags each binder in the program with its @Demand@.
112 That tells how each binder is {\em used}; if @Strict@, then the binder
113 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
114 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
116 (The above info is actually recorded for posterity in each binder's
117 IdInfo, notably its @DemandInfo@.)
119 We proceed by analysing the bindings top-to-bottom, building up an
120 environment which maps @Id@s to their abstract values (i.e., an
121 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
124 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
128 starting_abs_env = nullAbsValEnv
130 do_it starting_abs_env starting_abs_env binds
132 do_it _ _ [] = returnSa []
133 do_it senv aenv (b:bs)
134 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
135 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
136 returnSa (new_b : new_bs)
139 @saTopBind@ is only used for the top level. We don't add any demand
140 info to these ids because we can't work it out. In any case, it
141 doesn't do us any good to know whether top-level binders are sure to
142 be used; we can't turn top-level @let@s into @case@s.
145 saTopBind :: StrictEnv -> AbsenceEnv
147 -> SaM (StrictEnv, AbsenceEnv, CoreBind)
149 saTopBind str_env abs_env (NonRec binder rhs)
150 = saExpr minDemand str_env abs_env rhs `thenSa` \ new_rhs ->
152 str_rhs = absEval StrAnal rhs str_env
153 abs_rhs = absEval AbsAnal rhs abs_env
155 widened_str_rhs = widen StrAnal str_rhs
156 widened_abs_rhs = widen AbsAnal abs_rhs
157 -- The widening above is done for efficiency reasons.
158 -- See notes on Let case in SaAbsInt.lhs
161 = addStrictnessInfoToTopId
162 widened_str_rhs widened_abs_rhs
165 -- Augment environments with a mapping of the
166 -- binder to its abstract values, computed by absEval
167 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
168 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
170 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
172 saTopBind str_env abs_env (Rec pairs)
174 (binders,rhss) = unzip pairs
175 str_rhss = fixpoint StrAnal binders rhss str_env
176 abs_rhss = fixpoint AbsAnal binders rhss abs_env
177 -- fixpoint returns widened values
178 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
179 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
180 new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
181 str_rhss abs_rhss binders
183 mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
185 new_pairs = new_binders `zip` new_rhss
187 returnSa (new_str_env, new_abs_env, Rec new_pairs)
190 -- Top level divergent bindings are marked NOINLINE
191 -- This avoids fruitless inlining of top level error functions
192 addStrictnessInfoToTopId str_val abs_val bndr
193 = if isBottomingId new_id then
194 new_id `setInlinePragma` neverInlinePrag
198 new_id = addStrictnessInfoToId str_val abs_val bndr
201 %************************************************************************
203 \subsection[saExpr]{Strictness analysis of an expression}
205 %************************************************************************
207 @saExpr@ computes the strictness of an expression within a given
211 saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
212 -- The demand is the least demand we expect on the
213 -- expression. WwStrict is the least, because we're only
214 -- interested in the expression at all if it's being evaluated,
215 -- but the demand may be more. E.g.
217 -- where f has strictness u(LL), will evaluate E with demand u(LL)
220 minDemands = repeat minDemand
222 -- When we find an application, do the arguments
223 -- with demands gotten from the function
224 saApp str_env abs_env (fun, args)
225 = sequenceSa sa_args `thenSa` \ args' ->
226 saExpr minDemand str_env abs_env fun `thenSa` \ fun' ->
227 returnSa (mkApps fun' args')
229 arg_dmds = case fun of
230 Var var -> case lookupAbsValEnv str_env var of
231 Just (AbsApproxFun ds _) | length ds >= length args
236 sa_args = stretchZipWith isTypeArg (error "saApp:dmd")
238 -- The arg_dmds are for value args only, we need to skip
239 -- over the type args when pairing up with the demands
240 -- Hence the stretchZipWith
242 sa_arg arg dmd = saExpr dmd' str_env abs_env arg
244 -- Bring arg demand up to minDemand
245 dmd' | isLazy dmd = minDemand
248 saExpr _ _ _ e@(Var _) = returnSa e
249 saExpr _ _ _ e@(Lit _) = returnSa e
250 saExpr _ _ _ e@(Type _) = returnSa e
252 saExpr dmd str_env abs_env (Lam bndr body)
253 = -- Don't bother to set the demand-info on a lambda binder
254 -- We do that only for let(rec)-bound functions
255 saExpr minDemand str_env abs_env body `thenSa` \ new_body ->
256 returnSa (Lam bndr new_body)
258 saExpr dmd str_env abs_env e@(App fun arg)
259 = saApp str_env abs_env (collectArgs e)
261 saExpr dmd str_env abs_env (Note note expr)
262 = saExpr dmd str_env abs_env expr `thenSa` \ new_expr ->
263 returnSa (Note note new_expr)
265 saExpr dmd str_env abs_env (Case expr case_bndr alts)
266 = saExpr minDemand str_env abs_env expr `thenSa` \ new_expr ->
267 mapSa sa_alt alts `thenSa` \ new_alts ->
269 new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
271 returnSa (Case new_expr new_case_bndr new_alts)
273 sa_alt (con, binders, rhs)
274 = saExpr dmd str_env abs_env rhs `thenSa` \ new_rhs ->
276 new_binders = map add_demand_info binders
277 add_demand_info bndr | isTyVar bndr = bndr
278 | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr
280 tickCases new_binders `thenSa_` -- stats
281 returnSa (con, new_binders, new_rhs)
283 saExpr dmd str_env abs_env (Let (NonRec binder rhs) body)
284 = -- Analyse the RHS in the environment at hand
286 -- Find the demand on the RHS
287 rhs_dmd = findDemand dmd str_env abs_env body binder
289 -- Bind this binder to the abstract value of the RHS; analyse
290 -- the body of the `let' in the extended environment.
291 str_rhs_val = absEval StrAnal rhs str_env
292 abs_rhs_val = absEval AbsAnal rhs abs_env
294 widened_str_rhs = widen StrAnal str_rhs_val
295 widened_abs_rhs = widen AbsAnal abs_rhs_val
296 -- The widening above is done for efficiency reasons.
297 -- See notes on Let case in SaAbsInt.lhs
299 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
300 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
302 -- Now determine the strictness of this binder; use that info
303 -- to record DemandInfo/StrictnessInfo in the binder.
304 new_binder = addStrictnessInfoToId
305 widened_str_rhs widened_abs_rhs
306 (binder `setIdDemandInfo` rhs_dmd)
308 tickLet new_binder `thenSa_` -- stats
309 saExpr rhs_dmd str_env abs_env rhs `thenSa` \ new_rhs ->
310 saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body ->
311 returnSa (Let (NonRec new_binder new_rhs) new_body)
313 saExpr dmd str_env abs_env (Let (Rec pairs) body)
315 (binders,rhss) = unzip pairs
316 str_vals = fixpoint StrAnal binders rhss str_env
317 abs_vals = fixpoint AbsAnal binders rhss abs_env
318 -- fixpoint returns widened values
319 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
320 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
322 saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body ->
323 mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
325 -- DON'T add demand info in a Rec!
326 -- a) it's useless: we can't do let-to-case
327 -- b) it's incorrect. Consider
328 -- letrec x = ...y...
331 -- When we ask whether y is demanded we'll bind y to bottom and
332 -- evaluate the body of the letrec. But that will result in our
333 -- deciding that y is absent, which is plain wrong!
334 -- It's much easier simply not to do this.
336 improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
337 str_vals abs_vals binders
339 new_pairs = improved_binders `zip` new_rhss
341 returnSa (Let (Rec new_pairs) new_body)
345 %************************************************************************
347 \subsection[computeInfos]{Add computed info to binders}
349 %************************************************************************
351 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
352 let(rec) bound variables, and is use to attach the strictness (not
353 demand) info to the binder. We are careful to restrict this
354 strictness info to the lambda-bound arguments which are actually
355 visible, at the top level, lest we accidentally lose laziness by
356 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
357 rather syntactic way.
359 A better idea might be to have some kind of arity analysis to
360 tell how many args could safely be grabbed.
363 addStrictnessInfoToId
364 :: AbsVal -- Abstract strictness value
365 -> AbsVal -- Ditto absence
367 -> Id -- Augmented with strictness
369 addStrictnessInfoToId str_val abs_val binder
370 = binder `setIdStrictness` findStrictness binder str_val abs_val
374 addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
375 -> CoreExpr -- The scope of the id
377 -> Id -- Id augmented with Demand info
379 addDemandInfoToId dmd str_env abs_env expr binder
380 = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
382 addDemandInfoToCaseBndr dmd str_env abs_env alts binder
383 = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
386 %************************************************************************
388 \subsection{Monad used herein for stats}
390 %************************************************************************
394 = SaStats FastInt FastInt -- total/marked-demanded lambda-bound
395 FastInt FastInt -- total/marked-demanded case-bound
396 FastInt FastInt -- total/marked-demanded let-bound
397 -- (excl. top-level; excl. letrecs)
399 nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0)
401 thenSa :: SaM a -> (a -> SaM b) -> SaM b
402 thenSa_ :: SaM a -> SaM b -> SaM b
403 returnSa :: a -> SaM a
405 {-# INLINE thenSa #-}
406 {-# INLINE thenSa_ #-}
407 {-# INLINE returnSa #-}
409 tickLambda :: Id -> SaM ()
410 tickCases :: [CoreBndr] -> SaM ()
411 tickLet :: Id -> SaM ()
413 #ifndef OMIT_STRANAL_STATS
414 type SaM a = SaStats -> (a, SaStats)
416 thenSa expr cont stats
417 = case (expr stats) of { (result, stats1) ->
420 thenSa_ expr cont stats
421 = case (expr stats) of { (_, stats1) ->
424 returnSa x stats = (x, stats)
426 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
427 = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
428 let tot = iUnbox totB ; demanded = iUnbox demandedB
430 ((), SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) }
432 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
433 = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
434 let tot = iUnbox totB ; demanded = iUnbox demandedB
436 ((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) }
438 tickLet var (SaStats tlam dlam tc dc tlet dlet)
439 = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
440 let tot = iUnbox totB ; demanded = iUnbox demandedB
442 ((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) }
444 tick_demanded var (tot, demanded)
445 | isTyVar var = (tot, demanded)
448 if (isStrict (idDemandInfo var))
452 pp_stats (SaStats tlam dlam tc dc tlet dlet)
453 = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
454 ptext SLIT("; Case vars: "), int (iBox dc), char '/', int (iBox tc),
455 ptext SLIT("; Let vars: "), int (iBox dlet), char '/', int (iBox tlet)
458 #else {-OMIT_STRANAL_STATS-}
462 thenSa expr cont = cont expr
464 thenSa_ expr cont = cont
468 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
469 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
470 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
472 #endif {-OMIT_STRANAL_STATS-}
474 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
476 mapSa f [] = returnSa []
477 mapSa f (x:xs) = f x `thenSa` \ r ->
478 mapSa f xs `thenSa` \ rs ->
481 sequenceSa :: [SaM a] -> SaM [a]
482 sequenceSa [] = returnSa []
483 sequenceSa (m:ms) = m `thenSa` \ r ->
484 sequenceSa ms `thenSa` \ rs ->