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 ) )
44 %************************************************************************
46 \subsection[Thoughts]{Random thoughts}
48 %************************************************************************
50 A note about worker-wrappering. If we have
53 f = let v = <expensive>
56 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
58 f = \x -> case x of Int x# -> fw x#
59 fw = \x# -> let x = Int x#
64 because this obviously loses laziness, since now <expensive>
65 is done each time. Alas.
67 WATCH OUT! This can mean that something is unboxed only to be
68 boxed again. For example
72 Here g is strict, and *will* split into worker-wrapper. A call to
73 g, with the wrapper inlined will then be
75 case arg of Int a# -> gw a#
77 Now g calls f, which has no wrapper, so it has to box it.
79 gw = \a# -> f (Int a#)
84 %************************************************************************
86 \subsection[iface-StrictAnal]{Interface to the outside world}
88 %************************************************************************
90 @saBinds@ decorates bindings with strictness info. A later
91 worker-wrapper pass can use this info to create wrappers and
95 saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
98 -- Mark each binder with its strictness
99 #ifndef OMIT_STRANAL_STATS
100 let { (binds_w_strictness, sa_stats) = runState $ (saTopBinds binds) nullSaStats };
101 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
104 let { binds_w_strictness = unSaM $ saTopBindsBinds binds };
107 return binds_w_strictness
111 %************************************************************************
113 \subsection[saBinds]{Strictness analysis of bindings}
115 %************************************************************************
117 [Some of the documentation about types, etc., in \tr{SaLib} may be
118 helpful for understanding this module.]
120 @saTopBinds@ tags each binder in the program with its @Demand@.
121 That tells how each binder is {\em used}; if @Strict@, then the binder
122 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
123 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
125 (The above info is actually recorded for posterity in each binder's
126 IdInfo, notably its @DemandInfo@.)
128 We proceed by analysing the bindings top-to-bottom, building up an
129 environment which maps @Id@s to their abstract values (i.e., an
130 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
133 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
137 starting_abs_env = nullAbsValEnv
139 do_it starting_abs_env starting_abs_env binds
141 do_it _ _ [] = return []
142 do_it senv aenv (b:bs) = do
143 (senv2, aenv2, new_b) <- saTopBind senv aenv b
144 new_bs <- do_it senv2 aenv2 bs
145 return (new_b : new_bs)
148 @saTopBind@ is only used for the top level. We don't add any demand
149 info to these ids because we can't work it out. In any case, it
150 doesn't do us any good to know whether top-level binders are sure to
151 be used; we can't turn top-level @let@s into @case@s.
154 saTopBind :: StrictEnv -> AbsenceEnv
156 -> SaM (StrictEnv, AbsenceEnv, CoreBind)
158 saTopBind str_env abs_env (NonRec binder rhs) = do
159 new_rhs <- saExpr minDemand str_env abs_env rhs
161 str_rhs = absEval StrAnal rhs str_env
162 abs_rhs = absEval AbsAnal rhs abs_env
164 widened_str_rhs = widen StrAnal str_rhs
165 widened_abs_rhs = widen AbsAnal abs_rhs
166 -- The widening above is done for efficiency reasons.
167 -- See notes on Let case in SaAbsInt.lhs
170 = addStrictnessInfoToTopId
171 widened_str_rhs widened_abs_rhs
174 -- Augment environments with a mapping of the
175 -- binder to its abstract values, computed by absEval
176 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
177 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
179 return (new_str_env, new_abs_env, NonRec new_binder new_rhs)
181 saTopBind str_env abs_env (Rec pairs)
183 (binders,rhss) = unzip pairs
184 str_rhss = fixpoint StrAnal binders rhss str_env
185 abs_rhss = fixpoint AbsAnal binders rhss abs_env
186 -- fixpoint returns widened values
187 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
188 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
189 new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
190 str_rhss abs_rhss binders
192 new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
194 new_pairs = new_binders `zip` new_rhss
196 return (new_str_env, new_abs_env, Rec new_pairs)
199 -- Top level divergent bindings are marked NOINLINE
200 -- This avoids fruitless inlining of top level error functions
201 addStrictnessInfoToTopId str_val abs_val bndr
202 = if isBottomingId new_id then
203 new_id `setInlinePragma` NeverActive
207 new_id = addStrictnessInfoToId str_val abs_val bndr
210 %************************************************************************
212 \subsection[saExpr]{Strictness analysis of an expression}
214 %************************************************************************
216 @saExpr@ computes the strictness of an expression within a given
220 saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
221 -- The demand is the least demand we expect on the
222 -- expression. WwStrict is the least, because we're only
223 -- interested in the expression at all if it's being evaluated,
224 -- but the demand may be more. E.g.
226 -- where f has strictness u(LL), will evaluate E with demand u(LL)
229 minDemands = repeat minDemand
231 -- When we find an application, do the arguments
232 -- with demands gotten from the function
233 saApp str_env abs_env (fun, args) = do
234 args' <- sequence sa_args
235 fun' <- saExpr minDemand str_env abs_env fun
236 return (mkApps fun' args')
238 arg_dmds = case fun of
239 Var var -> case lookupAbsValEnv str_env var of
240 Just (AbsApproxFun ds _)
241 | compareLength ds args /= LT
242 -- 'ds' is at least as long as 'args'.
247 sa_args = stretchZipWith isTypeArg (error "saApp:dmd")
249 -- The arg_dmds are for value args only, we need to skip
250 -- over the type args when pairing up with the demands
251 -- Hence the stretchZipWith
253 sa_arg arg dmd = saExpr dmd' str_env abs_env arg
255 -- Bring arg demand up to minDemand
256 dmd' | isLazy dmd = minDemand
259 saExpr _ _ _ e@(Var _) = return e
260 saExpr _ _ _ e@(Lit _) = return e
261 saExpr _ _ _ e@(Type _) = return e
263 saExpr dmd str_env abs_env (Lam bndr body)
264 = do -- Don't bother to set the demand-info on a lambda binder
265 -- We do that only for let(rec)-bound functions
266 new_body <- saExpr minDemand str_env abs_env body
267 return (Lam bndr new_body)
269 saExpr dmd str_env abs_env e@(App fun arg)
270 = saApp str_env abs_env (collectArgs e)
272 saExpr dmd str_env abs_env (Note note expr) = do
273 new_expr <- saExpr dmd str_env abs_env expr
274 return (Note note new_expr)
276 saExpr dmd str_env abs_env (Case expr case_bndr alts) = do
277 new_expr <- saExpr minDemand str_env abs_env expr
278 new_alts <- mapM sa_alt alts
280 new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
281 return (Case new_expr new_case_bndr new_alts)
283 sa_alt (con, binders, rhs) = do
284 new_rhs <- saExpr dmd str_env abs_env rhs
286 new_binders = map add_demand_info binders
287 add_demand_info bndr | isTyVar bndr = bndr
288 | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr
290 tickCases new_binders -- stats
291 return (con, new_binders, new_rhs)
293 saExpr dmd str_env abs_env (Let (NonRec binder rhs) body) = do
294 -- Analyse the RHS in the environment at hand
296 -- Find the demand on the RHS
297 rhs_dmd = findDemand dmd str_env abs_env body binder
299 -- Bind this binder to the abstract value of the RHS; analyse
300 -- the body of the `let' in the extended environment.
301 str_rhs_val = absEval StrAnal rhs str_env
302 abs_rhs_val = absEval AbsAnal rhs abs_env
304 widened_str_rhs = widen StrAnal str_rhs_val
305 widened_abs_rhs = widen AbsAnal abs_rhs_val
306 -- The widening above is done for efficiency reasons.
307 -- See notes on Let case in SaAbsInt.lhs
309 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
310 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
312 -- Now determine the strictness of this binder; use that info
313 -- to record DemandInfo/StrictnessInfo in the binder.
314 new_binder = addStrictnessInfoToId
315 widened_str_rhs widened_abs_rhs
316 (binder `setIdDemandInfo` rhs_dmd)
318 tickLet new_binder -- stats
319 new_rhs <- saExpr rhs_dmd str_env abs_env rhs
320 new_body <- saExpr dmd new_str_env new_abs_env body
321 return (Let (NonRec new_binder new_rhs) new_body)
323 saExpr dmd str_env abs_env (Let (Rec pairs) body) = do
325 (binders,rhss) = unzip pairs
326 str_vals = fixpoint StrAnal binders rhss str_env
327 abs_vals = fixpoint AbsAnal binders rhss abs_env
328 -- fixpoint returns widened values
329 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
330 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
332 new_body <- saExpr dmd new_str_env new_abs_env body
333 new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
335 -- DON'T add demand info in a Rec!
336 -- a) it's useless: we can't do let-to-case
337 -- b) it's incorrect. Consider
338 -- letrec x = ...y...
341 -- When we ask whether y is demanded we'll bind y to bottom and
342 -- evaluate the body of the letrec. But that will result in our
343 -- deciding that y is absent, which is plain wrong!
344 -- It's much easier simply not to do this.
346 improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
347 str_vals abs_vals binders
349 new_pairs = improved_binders `zip` new_rhss
351 return (Let (Rec new_pairs) new_body)
355 %************************************************************************
357 \subsection[computeInfos]{Add computed info to binders}
359 %************************************************************************
361 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
362 let(rec) bound variables, and is use to attach the strictness (not
363 demand) info to the binder. We are careful to restrict this
364 strictness info to the lambda-bound arguments which are actually
365 visible, at the top level, lest we accidentally lose laziness by
366 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
367 rather syntactic way.
369 A better idea might be to have some kind of arity analysis to
370 tell how many args could safely be grabbed.
373 addStrictnessInfoToId
374 :: AbsVal -- Abstract strictness value
375 -> AbsVal -- Ditto absence
377 -> Id -- Augmented with strictness
379 addStrictnessInfoToId str_val abs_val binder
380 = binder `setIdStrictness` findStrictness binder str_val abs_val
384 addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
385 -> CoreExpr -- The scope of the id
387 -> Id -- Id augmented with Demand info
389 addDemandInfoToId dmd str_env abs_env expr binder
390 = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
392 addDemandInfoToCaseBndr dmd str_env abs_env alts binder
393 = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
396 %************************************************************************
398 \subsection{Monad used herein for stats}
400 %************************************************************************
404 = SaStats FastInt FastInt -- total/marked-demanded lambda-bound
405 FastInt FastInt -- total/marked-demanded case-bound
406 FastInt FastInt -- total/marked-demanded let-bound
407 -- (excl. top-level; excl. letrecs)
409 nullSaStats = SaStats
410 (_ILIT(0)) (_ILIT(0))
411 (_ILIT(0)) (_ILIT(0))
412 (_ILIT(0)) (_ILIT(0))
414 tickLambda :: Id -> SaM ()
415 tickCases :: [CoreBndr] -> SaM ()
416 tickLet :: Id -> SaM ()
418 #ifndef OMIT_STRANAL_STATS
419 type SaM a = State SaStats a
421 tickLambda var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
422 -> case (tick_demanded var (0,0)) of { (totB, demandedB) ->
423 let tot = iUnbox totB ; demanded = iUnbox demandedB
424 in SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet)
426 tickCases vars = modify $ \(SaStats tlam dlam tc dc tlet dlet)
427 = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
428 let tot = iUnbox totB ; demanded = iUnbox demandedB
429 in SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet)
431 tickLet var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
432 = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
433 let tot = iUnbox totB ; demanded = iUnbox demandedB
434 in SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded))
436 tick_demanded var (tot, demanded)
437 | isTyVar var = (tot, demanded)
440 if (isStrict (idDemandInfo var))
444 pp_stats (SaStats tlam dlam tc dc tlet dlet)
445 = hcat [ptext (sLit "Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
446 ptext (sLit "; Case vars: "), int (iBox dc), char '/', int (iBox tc),
447 ptext (sLit "; Let vars: "), int (iBox dlet), char '/', int (iBox tlet)
450 #else /* OMIT_STRANAL_STATS */
452 newtype SaM a = SaM { unSaM :: a }
454 instance Monad SaM where
458 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
459 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
460 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
462 #endif /* OMIT_STRANAL_STATS */
464 #endif /* OLD_STRICTNESS */