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"
98 (dopt Opt_D_dump_stranal dflags || dopt Opt_D_verbose_core2core dflags)
103 %************************************************************************
105 \subsection[saBinds]{Strictness analysis of bindings}
107 %************************************************************************
109 [Some of the documentation about types, etc., in \tr{SaLib} may be
110 helpful for understanding this module.]
112 @saTopBinds@ tags each binder in the program with its @Demand@.
113 That tells how each binder is {\em used}; if @Strict@, then the binder
114 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
115 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
117 (The above info is actually recorded for posterity in each binder's
118 IdInfo, notably its @DemandInfo@.)
120 We proceed by analysing the bindings top-to-bottom, building up an
121 environment which maps @Id@s to their abstract values (i.e., an
122 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
125 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
129 starting_abs_env = nullAbsValEnv
131 do_it starting_abs_env starting_abs_env binds
133 do_it _ _ [] = returnSa []
134 do_it senv aenv (b:bs)
135 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
136 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
137 returnSa (new_b : new_bs)
140 @saTopBind@ is only used for the top level. We don't add any demand
141 info to these ids because we can't work it out. In any case, it
142 doesn't do us any good to know whether top-level binders are sure to
143 be used; we can't turn top-level @let@s into @case@s.
146 saTopBind :: StrictEnv -> AbsenceEnv
148 -> SaM (StrictEnv, AbsenceEnv, CoreBind)
150 saTopBind str_env abs_env (NonRec binder rhs)
151 = saExpr minDemand str_env abs_env rhs `thenSa` \ new_rhs ->
153 str_rhs = absEval StrAnal rhs str_env
154 abs_rhs = absEval AbsAnal rhs abs_env
156 widened_str_rhs = widen StrAnal str_rhs
157 widened_abs_rhs = widen AbsAnal abs_rhs
158 -- The widening above is done for efficiency reasons.
159 -- See notes on Let case in SaAbsInt.lhs
162 = addStrictnessInfoToTopId
163 widened_str_rhs widened_abs_rhs
166 -- Augment environments with a mapping of the
167 -- binder to its abstract values, computed by absEval
168 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
169 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
171 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
173 saTopBind str_env abs_env (Rec pairs)
175 (binders,rhss) = unzip pairs
176 str_rhss = fixpoint StrAnal binders rhss str_env
177 abs_rhss = fixpoint AbsAnal binders rhss abs_env
178 -- fixpoint returns widened values
179 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
180 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
181 new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
182 str_rhss abs_rhss binders
184 mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
186 new_pairs = new_binders `zip` new_rhss
188 returnSa (new_str_env, new_abs_env, Rec new_pairs)
191 -- Top level divergent bindings are marked NOINLINE
192 -- This avoids fruitless inlining of top level error functions
193 addStrictnessInfoToTopId str_val abs_val bndr
194 = if isBottomingId new_id then
195 new_id `setInlinePragma` neverInlinePrag
199 new_id = addStrictnessInfoToId str_val abs_val bndr
202 %************************************************************************
204 \subsection[saExpr]{Strictness analysis of an expression}
206 %************************************************************************
208 @saExpr@ computes the strictness of an expression within a given
212 saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
213 -- The demand is the least demand we expect on the
214 -- expression. WwStrict is the least, because we're only
215 -- interested in the expression at all if it's being evaluated,
216 -- but the demand may be more. E.g.
218 -- where f has strictness u(LL), will evaluate E with demand u(LL)
221 minDemands = repeat minDemand
223 -- When we find an application, do the arguments
224 -- with demands gotten from the function
225 saApp str_env abs_env (fun, args)
226 = sequenceSa sa_args `thenSa` \ args' ->
227 saExpr minDemand str_env abs_env fun `thenSa` \ fun' ->
228 returnSa (mkApps fun' args')
230 arg_dmds = case fun of
231 Var var -> case lookupAbsValEnv str_env var of
232 Just (AbsApproxFun ds _) | length ds >= length args
237 sa_args = stretchZipWith isTypeArg (error "saApp:dmd")
239 -- The arg_dmds are for value args only, we need to skip
240 -- over the type args when pairing up with the demands
241 -- Hence the stretchZipWith
243 sa_arg arg dmd = saExpr dmd' str_env abs_env arg
245 -- Bring arg demand up to minDemand
246 dmd' | isLazy dmd = minDemand
249 saExpr _ _ _ e@(Var _) = returnSa e
250 saExpr _ _ _ e@(Lit _) = returnSa e
251 saExpr _ _ _ e@(Type _) = returnSa e
253 saExpr dmd str_env abs_env (Lam bndr body)
254 = -- Don't bother to set the demand-info on a lambda binder
255 -- We do that only for let(rec)-bound functions
256 saExpr minDemand str_env abs_env body `thenSa` \ new_body ->
257 returnSa (Lam bndr new_body)
259 saExpr dmd str_env abs_env e@(App fun arg)
260 = saApp str_env abs_env (collectArgs e)
262 saExpr dmd str_env abs_env (Note note expr)
263 = saExpr dmd str_env abs_env expr `thenSa` \ new_expr ->
264 returnSa (Note note new_expr)
266 saExpr dmd str_env abs_env (Case expr case_bndr alts)
267 = saExpr minDemand str_env abs_env expr `thenSa` \ new_expr ->
268 mapSa sa_alt alts `thenSa` \ new_alts ->
270 new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
272 returnSa (Case new_expr new_case_bndr new_alts)
274 sa_alt (con, binders, rhs)
275 = saExpr dmd str_env abs_env rhs `thenSa` \ new_rhs ->
277 new_binders = map add_demand_info binders
278 add_demand_info bndr | isTyVar bndr = bndr
279 | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr
281 tickCases new_binders `thenSa_` -- stats
282 returnSa (con, new_binders, new_rhs)
284 saExpr dmd str_env abs_env (Let (NonRec binder rhs) body)
285 = -- Analyse the RHS in the environment at hand
287 -- Find the demand on the RHS
288 rhs_dmd = findDemand dmd str_env abs_env body binder
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 (binder `setIdDemandInfo` rhs_dmd)
309 tickLet new_binder `thenSa_` -- stats
310 saExpr rhs_dmd str_env abs_env rhs `thenSa` \ new_rhs ->
311 saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body ->
312 returnSa (Let (NonRec new_binder new_rhs) new_body)
314 saExpr dmd 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 dmd new_str_env new_abs_env body `thenSa` \ new_body ->
324 mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
326 -- DON'T add demand info in a Rec!
327 -- a) it's useless: we can't do let-to-case
328 -- b) it's incorrect. Consider
329 -- letrec x = ...y...
332 -- When we ask whether y is demanded we'll bind y to bottom and
333 -- evaluate the body of the letrec. But that will result in our
334 -- deciding that y is absent, which is plain wrong!
335 -- It's much easier simply not to do this.
337 improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
338 str_vals abs_vals binders
340 new_pairs = improved_binders `zip` new_rhss
342 returnSa (Let (Rec new_pairs) new_body)
346 %************************************************************************
348 \subsection[computeInfos]{Add computed info to binders}
350 %************************************************************************
352 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
353 let(rec) bound variables, and is use to attach the strictness (not
354 demand) info to the binder. We are careful to restrict this
355 strictness info to the lambda-bound arguments which are actually
356 visible, at the top level, lest we accidentally lose laziness by
357 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
358 rather syntactic way.
360 A better idea might be to have some kind of arity analysis to
361 tell how many args could safely be grabbed.
364 addStrictnessInfoToId
365 :: AbsVal -- Abstract strictness value
366 -> AbsVal -- Ditto absence
368 -> Id -- Augmented with strictness
370 addStrictnessInfoToId str_val abs_val binder
371 = binder `setIdStrictness` findStrictness binder str_val abs_val
375 addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
376 -> CoreExpr -- The scope of the id
378 -> Id -- Id augmented with Demand info
380 addDemandInfoToId dmd str_env abs_env expr binder
381 = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
383 addDemandInfoToCaseBndr dmd str_env abs_env alts binder
384 = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
387 %************************************************************************
389 \subsection{Monad used herein for stats}
391 %************************************************************************
395 = SaStats FastInt FastInt -- total/marked-demanded lambda-bound
396 FastInt FastInt -- total/marked-demanded case-bound
397 FastInt FastInt -- total/marked-demanded let-bound
398 -- (excl. top-level; excl. letrecs)
400 nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0)
402 thenSa :: SaM a -> (a -> SaM b) -> SaM b
403 thenSa_ :: SaM a -> SaM b -> SaM b
404 returnSa :: a -> SaM a
406 {-# INLINE thenSa #-}
407 {-# INLINE thenSa_ #-}
408 {-# INLINE returnSa #-}
410 tickLambda :: Id -> SaM ()
411 tickCases :: [CoreBndr] -> SaM ()
412 tickLet :: Id -> SaM ()
414 #ifndef OMIT_STRANAL_STATS
415 type SaM a = SaStats -> (a, SaStats)
417 thenSa expr cont stats
418 = case (expr stats) of { (result, stats1) ->
421 thenSa_ expr cont stats
422 = case (expr stats) of { (_, stats1) ->
425 returnSa x stats = (x, stats)
427 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
428 = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
429 let tot = iUnbox totB ; demanded = iUnbox demandedB
431 ((), SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) }
433 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
434 = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
435 let tot = iUnbox totB ; demanded = iUnbox demandedB
437 ((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) }
439 tickLet var (SaStats tlam dlam tc dc tlet dlet)
440 = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
441 let tot = iUnbox totB ; demanded = iUnbox demandedB
443 ((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) }
445 tick_demanded var (tot, demanded)
446 | isTyVar var = (tot, demanded)
449 if (isStrict (idDemandInfo var))
453 pp_stats (SaStats tlam dlam tc dc tlet dlet)
454 = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
455 ptext SLIT("; Case vars: "), int (iBox dc), char '/', int (iBox tc),
456 ptext SLIT("; Let vars: "), int (iBox dlet), char '/', int (iBox tlet)
459 #else {-OMIT_STRANAL_STATS-}
463 thenSa expr cont = cont expr
465 thenSa_ expr cont = cont
469 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
470 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
471 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
473 #endif {-OMIT_STRANAL_STATS-}
475 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
477 mapSa f [] = returnSa []
478 mapSa f (x:xs) = f x `thenSa` \ r ->
479 mapSa f xs `thenSa` \ rs ->
482 sequenceSa :: [SaM a] -> SaM [a]
483 sequenceSa [] = returnSa []
484 sequenceSa (m:ms) = m `thenSa` \ r ->
485 sequenceSa ms `thenSa` \ rs ->