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.
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and fix
13 -- any warnings in the module. See
14 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 #ifndef OLD_STRICTNESS
18 module StrictAnal ( ) where
22 module StrictAnal ( saBinds ) where
24 #include "HsVersions.h"
26 import DynFlags ( DynFlags, DynFlag(..) )
28 import Id ( setIdStrictness, setInlinePragma,
29 idDemandInfo, setIdDemandInfo, isBottomingId,
32 import CoreLint ( showPass, endPass )
33 import ErrUtils ( dumpIfSet_dyn )
36 import Demand ( Demand, wwStrict, isStrict, isLazy )
37 import Util ( zipWith3Equal, stretchZipWith, compareLength )
38 import BasicTypes ( Activation( NeverActive ) )
43 %************************************************************************
45 \subsection[Thoughts]{Random thoughts}
47 %************************************************************************
49 A note about worker-wrappering. If we have
52 f = let v = <expensive>
55 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
57 f = \x -> case x of Int x# -> fw x#
58 fw = \x# -> let x = Int x#
63 because this obviously loses laziness, since now <expensive>
64 is done each time. Alas.
66 WATCH OUT! This can mean that something is unboxed only to be
67 boxed again. For example
71 Here g is strict, and *will* split into worker-wrapper. A call to
72 g, with the wrapper inlined will then be
74 case arg of Int a# -> gw a#
76 Now g calls f, which has no wrapper, so it has to box it.
78 gw = \a# -> f (Int a#)
83 %************************************************************************
85 \subsection[iface-StrictAnal]{Interface to the outside world}
87 %************************************************************************
89 @saBinds@ decorates bindings with strictness info. A later
90 worker-wrapper pass can use this info to create wrappers and
94 saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
97 showPass dflags "Strictness analysis";
99 -- Mark each binder with its strictness
100 #ifndef OMIT_STRANAL_STATS
101 let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
102 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
105 let { binds_w_strictness = saTopBindsBinds binds };
108 endPass dflags "Strictness analysis" Opt_D_dump_stranal
113 %************************************************************************
115 \subsection[saBinds]{Strictness analysis of bindings}
117 %************************************************************************
119 [Some of the documentation about types, etc., in \tr{SaLib} may be
120 helpful for understanding this module.]
122 @saTopBinds@ tags each binder in the program with its @Demand@.
123 That tells how each binder is {\em used}; if @Strict@, then the binder
124 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
125 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
127 (The above info is actually recorded for posterity in each binder's
128 IdInfo, notably its @DemandInfo@.)
130 We proceed by analysing the bindings top-to-bottom, building up an
131 environment which maps @Id@s to their abstract values (i.e., an
132 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
135 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
139 starting_abs_env = nullAbsValEnv
141 do_it starting_abs_env starting_abs_env binds
143 do_it _ _ [] = returnSa []
144 do_it senv aenv (b:bs)
145 = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) ->
146 do_it senv2 aenv2 bs `thenSa` \ new_bs ->
147 returnSa (new_b : new_bs)
150 @saTopBind@ is only used for the top level. We don't add any demand
151 info to these ids because we can't work it out. In any case, it
152 doesn't do us any good to know whether top-level binders are sure to
153 be used; we can't turn top-level @let@s into @case@s.
156 saTopBind :: StrictEnv -> AbsenceEnv
158 -> SaM (StrictEnv, AbsenceEnv, CoreBind)
160 saTopBind str_env abs_env (NonRec binder rhs)
161 = saExpr minDemand str_env abs_env rhs `thenSa` \ new_rhs ->
163 str_rhs = absEval StrAnal rhs str_env
164 abs_rhs = absEval AbsAnal rhs abs_env
166 widened_str_rhs = widen StrAnal str_rhs
167 widened_abs_rhs = widen AbsAnal abs_rhs
168 -- The widening above is done for efficiency reasons.
169 -- See notes on Let case in SaAbsInt.lhs
172 = addStrictnessInfoToTopId
173 widened_str_rhs widened_abs_rhs
176 -- Augment environments with a mapping of the
177 -- binder to its abstract values, computed by absEval
178 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
179 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
181 returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
183 saTopBind str_env abs_env (Rec pairs)
185 (binders,rhss) = unzip pairs
186 str_rhss = fixpoint StrAnal binders rhss str_env
187 abs_rhss = fixpoint AbsAnal binders rhss abs_env
188 -- fixpoint returns widened values
189 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
190 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
191 new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
192 str_rhss abs_rhss binders
194 mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
196 new_pairs = new_binders `zip` new_rhss
198 returnSa (new_str_env, new_abs_env, Rec new_pairs)
201 -- Top level divergent bindings are marked NOINLINE
202 -- This avoids fruitless inlining of top level error functions
203 addStrictnessInfoToTopId str_val abs_val bndr
204 = if isBottomingId new_id then
205 new_id `setInlinePragma` NeverActive
209 new_id = addStrictnessInfoToId str_val abs_val bndr
212 %************************************************************************
214 \subsection[saExpr]{Strictness analysis of an expression}
216 %************************************************************************
218 @saExpr@ computes the strictness of an expression within a given
222 saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
223 -- The demand is the least demand we expect on the
224 -- expression. WwStrict is the least, because we're only
225 -- interested in the expression at all if it's being evaluated,
226 -- but the demand may be more. E.g.
228 -- where f has strictness u(LL), will evaluate E with demand u(LL)
231 minDemands = repeat minDemand
233 -- When we find an application, do the arguments
234 -- with demands gotten from the function
235 saApp str_env abs_env (fun, args)
236 = sequenceSa sa_args `thenSa` \ args' ->
237 saExpr minDemand str_env abs_env fun `thenSa` \ fun' ->
238 returnSa (mkApps fun' args')
240 arg_dmds = case fun of
241 Var var -> case lookupAbsValEnv str_env var of
242 Just (AbsApproxFun ds _)
243 | compareLength ds args /= LT
244 -- 'ds' is at least as long as 'args'.
249 sa_args = stretchZipWith isTypeArg (error "saApp:dmd")
251 -- The arg_dmds are for value args only, we need to skip
252 -- over the type args when pairing up with the demands
253 -- Hence the stretchZipWith
255 sa_arg arg dmd = saExpr dmd' str_env abs_env arg
257 -- Bring arg demand up to minDemand
258 dmd' | isLazy dmd = minDemand
261 saExpr _ _ _ e@(Var _) = returnSa e
262 saExpr _ _ _ e@(Lit _) = returnSa e
263 saExpr _ _ _ e@(Type _) = returnSa e
265 saExpr dmd str_env abs_env (Lam bndr body)
266 = -- Don't bother to set the demand-info on a lambda binder
267 -- We do that only for let(rec)-bound functions
268 saExpr minDemand str_env abs_env body `thenSa` \ new_body ->
269 returnSa (Lam bndr new_body)
271 saExpr dmd str_env abs_env e@(App fun arg)
272 = saApp str_env abs_env (collectArgs e)
274 saExpr dmd str_env abs_env (Note note expr)
275 = saExpr dmd str_env abs_env expr `thenSa` \ new_expr ->
276 returnSa (Note note new_expr)
278 saExpr dmd str_env abs_env (Case expr case_bndr alts)
279 = saExpr minDemand str_env abs_env expr `thenSa` \ new_expr ->
280 mapSa sa_alt alts `thenSa` \ new_alts ->
282 new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
284 returnSa (Case new_expr new_case_bndr new_alts)
286 sa_alt (con, binders, rhs)
287 = saExpr dmd str_env abs_env rhs `thenSa` \ new_rhs ->
289 new_binders = map add_demand_info binders
290 add_demand_info bndr | isTyVar bndr = bndr
291 | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr
293 tickCases new_binders `thenSa_` -- stats
294 returnSa (con, new_binders, new_rhs)
296 saExpr dmd str_env abs_env (Let (NonRec binder rhs) body)
297 = -- Analyse the RHS in the environment at hand
299 -- Find the demand on the RHS
300 rhs_dmd = findDemand dmd str_env abs_env body binder
302 -- Bind this binder to the abstract value of the RHS; analyse
303 -- the body of the `let' in the extended environment.
304 str_rhs_val = absEval StrAnal rhs str_env
305 abs_rhs_val = absEval AbsAnal rhs abs_env
307 widened_str_rhs = widen StrAnal str_rhs_val
308 widened_abs_rhs = widen AbsAnal abs_rhs_val
309 -- The widening above is done for efficiency reasons.
310 -- See notes on Let case in SaAbsInt.lhs
312 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
313 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
315 -- Now determine the strictness of this binder; use that info
316 -- to record DemandInfo/StrictnessInfo in the binder.
317 new_binder = addStrictnessInfoToId
318 widened_str_rhs widened_abs_rhs
319 (binder `setIdDemandInfo` rhs_dmd)
321 tickLet new_binder `thenSa_` -- stats
322 saExpr rhs_dmd str_env abs_env rhs `thenSa` \ new_rhs ->
323 saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body ->
324 returnSa (Let (NonRec new_binder new_rhs) new_body)
326 saExpr dmd str_env abs_env (Let (Rec pairs) body)
328 (binders,rhss) = unzip pairs
329 str_vals = fixpoint StrAnal binders rhss str_env
330 abs_vals = fixpoint AbsAnal binders rhss abs_env
331 -- fixpoint returns widened values
332 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
333 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
335 saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body ->
336 mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
338 -- DON'T add demand info in a Rec!
339 -- a) it's useless: we can't do let-to-case
340 -- b) it's incorrect. Consider
341 -- letrec x = ...y...
344 -- When we ask whether y is demanded we'll bind y to bottom and
345 -- evaluate the body of the letrec. But that will result in our
346 -- deciding that y is absent, which is plain wrong!
347 -- It's much easier simply not to do this.
349 improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
350 str_vals abs_vals binders
352 new_pairs = improved_binders `zip` new_rhss
354 returnSa (Let (Rec new_pairs) new_body)
358 %************************************************************************
360 \subsection[computeInfos]{Add computed info to binders}
362 %************************************************************************
364 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
365 let(rec) bound variables, and is use to attach the strictness (not
366 demand) info to the binder. We are careful to restrict this
367 strictness info to the lambda-bound arguments which are actually
368 visible, at the top level, lest we accidentally lose laziness by
369 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
370 rather syntactic way.
372 A better idea might be to have some kind of arity analysis to
373 tell how many args could safely be grabbed.
376 addStrictnessInfoToId
377 :: AbsVal -- Abstract strictness value
378 -> AbsVal -- Ditto absence
380 -> Id -- Augmented with strictness
382 addStrictnessInfoToId str_val abs_val binder
383 = binder `setIdStrictness` findStrictness binder str_val abs_val
387 addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
388 -> CoreExpr -- The scope of the id
390 -> Id -- Id augmented with Demand info
392 addDemandInfoToId dmd str_env abs_env expr binder
393 = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
395 addDemandInfoToCaseBndr dmd str_env abs_env alts binder
396 = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
399 %************************************************************************
401 \subsection{Monad used herein for stats}
403 %************************************************************************
407 = SaStats FastInt FastInt -- total/marked-demanded lambda-bound
408 FastInt FastInt -- total/marked-demanded case-bound
409 FastInt FastInt -- total/marked-demanded let-bound
410 -- (excl. top-level; excl. letrecs)
412 nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0)
414 thenSa :: SaM a -> (a -> SaM b) -> SaM b
415 thenSa_ :: SaM a -> SaM b -> SaM b
416 returnSa :: a -> SaM a
418 {-# INLINE thenSa #-}
419 {-# INLINE thenSa_ #-}
420 {-# INLINE returnSa #-}
422 tickLambda :: Id -> SaM ()
423 tickCases :: [CoreBndr] -> SaM ()
424 tickLet :: Id -> SaM ()
426 #ifndef OMIT_STRANAL_STATS
427 type SaM a = SaStats -> (a, SaStats)
429 thenSa expr cont stats
430 = case (expr stats) of { (result, stats1) ->
433 thenSa_ expr cont stats
434 = case (expr stats) of { (_, stats1) ->
437 returnSa x stats = (x, stats)
439 tickLambda 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 +# tot) (dlam +# demanded) tc dc tlet dlet) }
445 tickCases vars (SaStats tlam dlam tc dc tlet dlet)
446 = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
447 let tot = iUnbox totB ; demanded = iUnbox demandedB
449 ((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) }
451 tickLet var (SaStats tlam dlam tc dc tlet dlet)
452 = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
453 let tot = iUnbox totB ; demanded = iUnbox demandedB
455 ((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) }
457 tick_demanded var (tot, demanded)
458 | isTyVar var = (tot, demanded)
461 if (isStrict (idDemandInfo var))
465 pp_stats (SaStats tlam dlam tc dc tlet dlet)
466 = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
467 ptext SLIT("; Case vars: "), int (iBox dc), char '/', int (iBox tc),
468 ptext SLIT("; Let vars: "), int (iBox dlet), char '/', int (iBox tlet)
471 #else /* OMIT_STRANAL_STATS */
475 thenSa expr cont = cont expr
477 thenSa_ expr cont = cont
481 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
482 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
483 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
485 #endif /* OMIT_STRANAL_STATS */
487 mapSa :: (a -> SaM b) -> [a] -> SaM [b]
489 mapSa f [] = returnSa []
490 mapSa f (x:xs) = f x `thenSa` \ r ->
491 mapSa f xs `thenSa` \ rs ->
494 sequenceSa :: [SaM a] -> SaM [a]
495 sequenceSa [] = returnSa []
496 sequenceSa (m:ms) = m `thenSa` \ r ->
497 sequenceSa ms `thenSa` \ rs ->
500 #endif /* OLD_STRICTNESS */