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 ( opt_D_dump_stranal, opt_D_dump_simpl_stats, opt_D_verbose_core2core )
16 import Id ( setIdStrictness, setInlinePragma,
17 idDemandInfo, setIdDemandInfo, isBottomingId,
20 import IdInfo ( neverInlinePrag )
21 import CoreLint ( beginPass, endPass )
22 import ErrUtils ( dumpIfSet )
25 import Demand ( Demand, wwStrict, isStrict, isLazy )
26 import Util ( zipWith3Equal, stretchZipWith )
30 %************************************************************************
32 \subsection[Thoughts]{Random thoughts}
34 %************************************************************************
36 A note about worker-wrappering. If we have
39 f = let v = <expensive>
42 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
44 f = \x -> case x of Int x# -> fw x#
45 fw = \x# -> let x = Int x#
50 because this obviously loses laziness, since now <expensive>
51 is done each time. Alas.
53 WATCH OUT! This can mean that something is unboxed only to be
54 boxed again. For example
58 Here g is strict, and *will* split into worker-wrapper. A call to
59 g, with the wrapper inlined will then be
61 case arg of Int a# -> gw a#
63 Now g calls f, which has no wrapper, so it has to box it.
65 gw = \a# -> f (Int a#)
70 %************************************************************************
72 \subsection[iface-StrictAnal]{Interface to the outside world}
74 %************************************************************************
76 @saBinds@ decorates bindings with strictness info. A later
77 worker-wrapper pass can use this info to create wrappers and
86 beginPass "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 opt_D_dump_simpl_stats "Strictness analysis statistics"
94 let { binds_w_strictness = saTopBindsBinds binds };
97 endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds_w_strictness
101 %************************************************************************
103 \subsection[saBinds]{Strictness analysis of bindings}
105 %************************************************************************
107 [Some of the documentation about types, etc., in \tr{SaLib} may be
108 helpful for understanding this module.]
110 @saTopBinds@ tags each binder in the program with its @Demand@.
111 That tells how each binder is {\em used}; if @Strict@, then the binder
112 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
113 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
115 (The above info is actually recorded for posterity in each binder's
116 IdInfo, notably its @DemandInfo@.)
118 We proceed by analysing the bindings top-to-bottom, building up an
119 environment which maps @Id@s to their abstract values (i.e., an
120 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
123 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
127 starting_abs_env = nullAbsValEnv
129 do_it starting_abs_env starting_abs_env binds
131 do_it _ _ [] = returnSa []
132 do_it senv aenv (b:bs)
133 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
134 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
135 returnSa (new_b : new_bs)
138 @saTopBind@ is only used for the top level. We don't add any demand
139 info to these ids because we can't work it out. In any case, it
140 doesn't do us any good to know whether top-level binders are sure to
141 be used; we can't turn top-level @let@s into @case@s.
144 saTopBind :: StrictEnv -> AbsenceEnv
146 -> SaM (StrictEnv, AbsenceEnv, CoreBind)
148 saTopBind str_env abs_env (NonRec binder rhs)
149 = saExpr minDemand str_env abs_env rhs `thenSa` \ new_rhs ->
151 str_rhs = absEval StrAnal rhs str_env
152 abs_rhs = absEval AbsAnal rhs abs_env
154 widened_str_rhs = widen StrAnal str_rhs
155 widened_abs_rhs = widen AbsAnal abs_rhs
156 -- The widening above is done for efficiency reasons.
157 -- See notes on Let case in SaAbsInt.lhs
160 = addStrictnessInfoToTopId
161 widened_str_rhs widened_abs_rhs
164 -- Augment environments with a mapping of the
165 -- binder to its abstract values, computed by absEval
166 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
167 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
169 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
171 saTopBind str_env abs_env (Rec pairs)
173 (binders,rhss) = unzip pairs
174 str_rhss = fixpoint StrAnal binders rhss str_env
175 abs_rhss = fixpoint AbsAnal binders rhss abs_env
176 -- fixpoint returns widened values
177 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
178 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
179 new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
180 str_rhss abs_rhss binders
182 mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
184 new_pairs = new_binders `zip` new_rhss
186 returnSa (new_str_env, new_abs_env, Rec new_pairs)
189 -- Top level divergent bindings are marked NOINLINE
190 -- This avoids fruitless inlining of top level error functions
191 addStrictnessInfoToTopId str_val abs_val bndr
192 = if isBottomingId new_id then
193 new_id `setInlinePragma` neverInlinePrag
197 new_id = addStrictnessInfoToId str_val abs_val bndr
200 %************************************************************************
202 \subsection[saExpr]{Strictness analysis of an expression}
204 %************************************************************************
206 @saExpr@ computes the strictness of an expression within a given
210 saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
211 -- The demand is the least demand we expect on the
212 -- expression. WwStrict is the least, because we're only
213 -- interested in the expression at all if it's being evaluated,
214 -- but the demand may be more. E.g.
216 -- where f has strictness u(LL), will evaluate E with demand u(LL)
219 minDemands = repeat minDemand
221 -- When we find an application, do the arguments
222 -- with demands gotten from the function
223 saApp str_env abs_env (fun, args)
224 = sequenceSa sa_args `thenSa` \ args' ->
225 saExpr minDemand str_env abs_env fun `thenSa` \ fun' ->
226 returnSa (mkApps fun' args')
228 arg_dmds = case fun of
229 Var var -> case lookupAbsValEnv str_env var of
230 Just (AbsApproxFun ds _) | length ds >= length args
235 sa_args = stretchZipWith isTypeArg (error "saApp:dmd")
237 -- The arg_dmds are for value args only, we need to skip
238 -- over the type args when pairing up with the demands
239 -- Hence the stretchZipWith
241 sa_arg arg dmd = saExpr dmd' str_env abs_env arg
243 -- Bring arg demand up to minDemand
244 dmd' | isLazy dmd = minDemand
247 saExpr _ _ _ e@(Var _) = returnSa e
248 saExpr _ _ _ e@(Lit _) = returnSa e
249 saExpr _ _ _ e@(Type _) = returnSa e
251 saExpr dmd str_env abs_env (Lam bndr body)
252 = -- Don't bother to set the demand-info on a lambda binder
253 -- We do that only for let(rec)-bound functions
254 saExpr minDemand str_env abs_env body `thenSa` \ new_body ->
255 returnSa (Lam bndr new_body)
257 saExpr dmd str_env abs_env e@(App fun arg)
258 = saApp str_env abs_env (collectArgs e)
260 saExpr dmd str_env abs_env (Note note expr)
261 = saExpr dmd str_env abs_env expr `thenSa` \ new_expr ->
262 returnSa (Note note new_expr)
264 saExpr dmd str_env abs_env (Case expr case_bndr alts)
265 = saExpr minDemand str_env abs_env expr `thenSa` \ new_expr ->
266 mapSa sa_alt alts `thenSa` \ new_alts ->
268 new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
270 returnSa (Case new_expr new_case_bndr new_alts)
272 sa_alt (con, binders, rhs)
273 = saExpr dmd str_env abs_env rhs `thenSa` \ new_rhs ->
275 new_binders = map add_demand_info binders
276 add_demand_info bndr | isTyVar bndr = bndr
277 | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr
279 tickCases new_binders `thenSa_` -- stats
280 returnSa (con, new_binders, new_rhs)
282 saExpr dmd str_env abs_env (Let (NonRec binder rhs) body)
283 = -- Analyse the RHS in the environment at hand
285 -- Find the demand on the RHS
286 rhs_dmd = findDemand dmd str_env abs_env body binder
288 -- Bind this binder to the abstract value of the RHS; analyse
289 -- the body of the `let' in the extended environment.
290 str_rhs_val = absEval StrAnal rhs str_env
291 abs_rhs_val = absEval AbsAnal rhs abs_env
293 widened_str_rhs = widen StrAnal str_rhs_val
294 widened_abs_rhs = widen AbsAnal abs_rhs_val
295 -- The widening above is done for efficiency reasons.
296 -- See notes on Let case in SaAbsInt.lhs
298 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
299 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
301 -- Now determine the strictness of this binder; use that info
302 -- to record DemandInfo/StrictnessInfo in the binder.
303 new_binder = addStrictnessInfoToId
304 widened_str_rhs widened_abs_rhs
305 (binder `setIdDemandInfo` rhs_dmd)
307 tickLet new_binder `thenSa_` -- stats
308 saExpr rhs_dmd str_env abs_env rhs `thenSa` \ new_rhs ->
309 saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body ->
310 returnSa (Let (NonRec new_binder new_rhs) new_body)
312 saExpr dmd str_env abs_env (Let (Rec pairs) body)
314 (binders,rhss) = unzip pairs
315 str_vals = fixpoint StrAnal binders rhss str_env
316 abs_vals = fixpoint AbsAnal binders rhss abs_env
317 -- fixpoint returns widened values
318 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
319 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
321 saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body ->
322 mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
324 -- DON'T add demand info in a Rec!
325 -- a) it's useless: we can't do let-to-case
326 -- b) it's incorrect. Consider
327 -- letrec x = ...y...
330 -- When we ask whether y is demanded we'll bind y to bottom and
331 -- evaluate the body of the letrec. But that will result in our
332 -- deciding that y is absent, which is plain wrong!
333 -- It's much easier simply not to do this.
335 improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
336 str_vals abs_vals binders
338 new_pairs = improved_binders `zip` new_rhss
340 returnSa (Let (Rec new_pairs) new_body)
344 %************************************************************************
346 \subsection[computeInfos]{Add computed info to binders}
348 %************************************************************************
350 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
351 let(rec) bound variables, and is use to attach the strictness (not
352 demand) info to the binder. We are careful to restrict this
353 strictness info to the lambda-bound arguments which are actually
354 visible, at the top level, lest we accidentally lose laziness by
355 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
356 rather syntactic way.
358 A better idea might be to have some kind of arity analysis to
359 tell how many args could safely be grabbed.
362 addStrictnessInfoToId
363 :: AbsVal -- Abstract strictness value
364 -> AbsVal -- Ditto absence
366 -> Id -- Augmented with strictness
368 addStrictnessInfoToId str_val abs_val binder
369 = binder `setIdStrictness` findStrictness binder str_val abs_val
373 addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
374 -> CoreExpr -- The scope of the id
376 -> Id -- Id augmented with Demand info
378 addDemandInfoToId dmd str_env abs_env expr binder
379 = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
381 addDemandInfoToCaseBndr dmd str_env abs_env alts binder
382 = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
385 %************************************************************************
387 \subsection{Monad used herein for stats}
389 %************************************************************************
393 = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound
394 FAST_INT FAST_INT -- total/marked-demanded case-bound
395 FAST_INT FAST_INT -- total/marked-demanded let-bound
396 -- (excl. top-level; excl. letrecs)
398 nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
400 thenSa :: SaM a -> (a -> SaM b) -> SaM b
401 thenSa_ :: SaM a -> SaM b -> SaM b
402 returnSa :: a -> SaM a
404 {-# INLINE thenSa #-}
405 {-# INLINE thenSa_ #-}
406 {-# INLINE returnSa #-}
408 tickLambda :: Id -> SaM ()
409 tickCases :: [CoreBndr] -> SaM ()
410 tickLet :: Id -> SaM ()
412 #ifndef OMIT_STRANAL_STATS
413 type SaM a = SaStats -> (a, SaStats)
415 thenSa expr cont stats
416 = case (expr stats) of { (result, stats1) ->
419 thenSa_ expr cont stats
420 = case (expr stats) of { (_, stats1) ->
423 returnSa x stats = (x, stats)
425 tickLambda var (SaStats tlam dlam tc dc tlet dlet)
426 = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
427 ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
429 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
430 = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
431 ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) }
433 tickLet var (SaStats tlam dlam tc dc tlet dlet)
434 = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
435 ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) }
437 tick_demanded var (tot, demanded)
438 | isTyVar var = (tot, demanded)
441 if (isStrict (idDemandInfo var))
445 pp_stats (SaStats tlam dlam tc dc tlet dlet)
446 = hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
447 ptext SLIT("; Case vars: "), int IBOX(dc), char '/', int IBOX(tc),
448 ptext SLIT("; Let vars: "), int IBOX(dlet), char '/', int IBOX(tlet)
451 #else {-OMIT_STRANAL_STATS-}
455 thenSa expr cont = cont expr
457 thenSa_ expr cont = cont
461 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
462 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
463 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
465 #endif {-OMIT_STRANAL_STATS-}
467 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
469 mapSa f [] = returnSa []
470 mapSa f (x:xs) = f x `thenSa` \ r ->
471 mapSa f xs `thenSa` \ rs ->
474 sequenceSa :: [SaM a] -> SaM [a]
475 sequenceSa [] = returnSa []
476 sequenceSa (m:ms) = m `thenSa` \ r ->
477 sequenceSa ms `thenSa` \ rs ->