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 ErrUtils ( dumpIfSet_dyn )
35 import Demand ( Demand, wwStrict, isStrict, isLazy )
36 import Util ( zipWith3Equal, stretchZipWith, compareLength )
37 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 -- Mark each binder with its strictness
98 #ifndef OMIT_STRANAL_STATS
99 let { (binds_w_strictness, sa_stats) = runState $ (saTopBinds binds) nullSaStats };
100 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
103 let { binds_w_strictness = unSaM $ saTopBindsBinds binds };
106 return binds_w_strictness
110 %************************************************************************
112 \subsection[saBinds]{Strictness analysis of bindings}
114 %************************************************************************
116 [Some of the documentation about types, etc., in \tr{SaLib} may be
117 helpful for understanding this module.]
119 @saTopBinds@ tags each binder in the program with its @Demand@.
120 That tells how each binder is {\em used}; if @Strict@, then the binder
121 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
122 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
124 (The above info is actually recorded for posterity in each binder's
125 IdInfo, notably its @DemandInfo@.)
127 We proceed by analysing the bindings top-to-bottom, building up an
128 environment which maps @Id@s to their abstract values (i.e., an
129 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
132 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
136 starting_abs_env = nullAbsValEnv
138 do_it starting_abs_env starting_abs_env binds
140 do_it _ _ [] = return []
141 do_it senv aenv (b:bs) = do
142 (senv2, aenv2, new_b) <- saTopBind senv aenv b
143 new_bs <- do_it senv2 aenv2 bs
144 return (new_b : new_bs)
147 @saTopBind@ is only used for the top level. We don't add any demand
148 info to these ids because we can't work it out. In any case, it
149 doesn't do us any good to know whether top-level binders are sure to
150 be used; we can't turn top-level @let@s into @case@s.
153 saTopBind :: StrictEnv -> AbsenceEnv
155 -> SaM (StrictEnv, AbsenceEnv, CoreBind)
157 saTopBind str_env abs_env (NonRec binder rhs) = do
158 new_rhs <- saExpr minDemand str_env abs_env rhs
160 str_rhs = absEval StrAnal rhs str_env
161 abs_rhs = absEval AbsAnal rhs abs_env
163 widened_str_rhs = widen StrAnal str_rhs
164 widened_abs_rhs = widen AbsAnal abs_rhs
165 -- The widening above is done for efficiency reasons.
166 -- See notes on Let case in SaAbsInt.lhs
169 = addStrictnessInfoToTopId
170 widened_str_rhs widened_abs_rhs
173 -- Augment environments with a mapping of the
174 -- binder to its abstract values, computed by absEval
175 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
176 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
178 return (new_str_env, new_abs_env, NonRec new_binder new_rhs)
180 saTopBind str_env abs_env (Rec pairs)
182 (binders,rhss) = unzip pairs
183 str_rhss = fixpoint StrAnal binders rhss str_env
184 abs_rhss = fixpoint AbsAnal binders rhss abs_env
185 -- fixpoint returns widened values
186 new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
187 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
188 new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
189 str_rhss abs_rhss binders
191 new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
193 new_pairs = new_binders `zip` new_rhss
195 return (new_str_env, new_abs_env, Rec new_pairs)
198 -- Top level divergent bindings are marked NOINLINE
199 -- This avoids fruitless inlining of top level error functions
200 addStrictnessInfoToTopId str_val abs_val bndr
201 = if isBottomingId new_id then
202 new_id `setInlinePragma` NeverActive
206 new_id = addStrictnessInfoToId str_val abs_val bndr
209 %************************************************************************
211 \subsection[saExpr]{Strictness analysis of an expression}
213 %************************************************************************
215 @saExpr@ computes the strictness of an expression within a given
219 saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
220 -- The demand is the least demand we expect on the
221 -- expression. WwStrict is the least, because we're only
222 -- interested in the expression at all if it's being evaluated,
223 -- but the demand may be more. E.g.
225 -- where f has strictness u(LL), will evaluate E with demand u(LL)
228 minDemands = repeat minDemand
230 -- When we find an application, do the arguments
231 -- with demands gotten from the function
232 saApp str_env abs_env (fun, args) = do
233 args' <- sequence sa_args
234 fun' <- saExpr minDemand str_env abs_env fun
235 return (mkApps fun' args')
237 arg_dmds = case fun of
238 Var var -> case lookupAbsValEnv str_env var of
239 Just (AbsApproxFun ds _)
240 | compareLength ds args /= LT
241 -- 'ds' is at least as long as 'args'.
246 sa_args = stretchZipWith isTypeArg (error "saApp:dmd")
248 -- The arg_dmds are for value args only, we need to skip
249 -- over the type args when pairing up with the demands
250 -- Hence the stretchZipWith
252 sa_arg arg dmd = saExpr dmd' str_env abs_env arg
254 -- Bring arg demand up to minDemand
255 dmd' | isLazy dmd = minDemand
258 saExpr _ _ _ e@(Var _) = return e
259 saExpr _ _ _ e@(Lit _) = return e
260 saExpr _ _ _ e@(Type _) = return e
262 saExpr dmd str_env abs_env (Lam bndr body)
263 = do -- Don't bother to set the demand-info on a lambda binder
264 -- We do that only for let(rec)-bound functions
265 new_body <- saExpr minDemand str_env abs_env body
266 return (Lam bndr new_body)
268 saExpr dmd str_env abs_env e@(App fun arg)
269 = saApp str_env abs_env (collectArgs e)
271 saExpr dmd str_env abs_env (Note note expr) = do
272 new_expr <- saExpr dmd str_env abs_env expr
273 return (Note note new_expr)
275 saExpr dmd str_env abs_env (Case expr case_bndr alts) = do
276 new_expr <- saExpr minDemand str_env abs_env expr
277 new_alts <- mapM sa_alt alts
279 new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
280 return (Case new_expr new_case_bndr new_alts)
282 sa_alt (con, binders, rhs) = do
283 new_rhs <- saExpr dmd str_env abs_env rhs
285 new_binders = map add_demand_info binders
286 add_demand_info bndr | isTyVar bndr = bndr
287 | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr
289 tickCases new_binders -- stats
290 return (con, new_binders, new_rhs)
292 saExpr dmd str_env abs_env (Let (NonRec binder rhs) body) = do
293 -- Analyse the RHS in the environment at hand
295 -- Find the demand on the RHS
296 rhs_dmd = findDemand dmd str_env abs_env body binder
298 -- Bind this binder to the abstract value of the RHS; analyse
299 -- the body of the `let' in the extended environment.
300 str_rhs_val = absEval StrAnal rhs str_env
301 abs_rhs_val = absEval AbsAnal rhs abs_env
303 widened_str_rhs = widen StrAnal str_rhs_val
304 widened_abs_rhs = widen AbsAnal abs_rhs_val
305 -- The widening above is done for efficiency reasons.
306 -- See notes on Let case in SaAbsInt.lhs
308 new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
309 new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
311 -- Now determine the strictness of this binder; use that info
312 -- to record DemandInfo/StrictnessInfo in the binder.
313 new_binder = addStrictnessInfoToId
314 widened_str_rhs widened_abs_rhs
315 (binder `setIdDemandInfo` rhs_dmd)
317 tickLet new_binder -- stats
318 new_rhs <- saExpr rhs_dmd str_env abs_env rhs
319 new_body <- saExpr dmd new_str_env new_abs_env body
320 return (Let (NonRec new_binder new_rhs) new_body)
322 saExpr dmd str_env abs_env (Let (Rec pairs) body) = do
324 (binders,rhss) = unzip pairs
325 str_vals = fixpoint StrAnal binders rhss str_env
326 abs_vals = fixpoint AbsAnal binders rhss abs_env
327 -- fixpoint returns widened values
328 new_str_env = growAbsValEnvList str_env (binders `zip` str_vals)
329 new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals)
331 new_body <- saExpr dmd new_str_env new_abs_env body
332 new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
334 -- DON'T add demand info in a Rec!
335 -- a) it's useless: we can't do let-to-case
336 -- b) it's incorrect. Consider
337 -- letrec x = ...y...
340 -- When we ask whether y is demanded we'll bind y to bottom and
341 -- evaluate the body of the letrec. But that will result in our
342 -- deciding that y is absent, which is plain wrong!
343 -- It's much easier simply not to do this.
345 improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
346 str_vals abs_vals binders
348 new_pairs = improved_binders `zip` new_rhss
350 return (Let (Rec new_pairs) new_body)
354 %************************************************************************
356 \subsection[computeInfos]{Add computed info to binders}
358 %************************************************************************
360 Important note (Sept 93). @addStrictnessInfoToId@ is used only for
361 let(rec) bound variables, and is use to attach the strictness (not
362 demand) info to the binder. We are careful to restrict this
363 strictness info to the lambda-bound arguments which are actually
364 visible, at the top level, lest we accidentally lose laziness by
365 eagerly looking for an "extra" argument. So we "dig for lambdas" in a
366 rather syntactic way.
368 A better idea might be to have some kind of arity analysis to
369 tell how many args could safely be grabbed.
372 addStrictnessInfoToId
373 :: AbsVal -- Abstract strictness value
374 -> AbsVal -- Ditto absence
376 -> Id -- Augmented with strictness
378 addStrictnessInfoToId str_val abs_val binder
379 = binder `setIdStrictness` findStrictness binder str_val abs_val
383 addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
384 -> CoreExpr -- The scope of the id
386 -> Id -- Id augmented with Demand info
388 addDemandInfoToId dmd str_env abs_env expr binder
389 = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
391 addDemandInfoToCaseBndr dmd str_env abs_env alts binder
392 = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
395 %************************************************************************
397 \subsection{Monad used herein for stats}
399 %************************************************************************
403 = SaStats FastInt FastInt -- total/marked-demanded lambda-bound
404 FastInt FastInt -- total/marked-demanded case-bound
405 FastInt FastInt -- total/marked-demanded let-bound
406 -- (excl. top-level; excl. letrecs)
408 nullSaStats = SaStats
409 (_ILIT(0)) (_ILIT(0))
410 (_ILIT(0)) (_ILIT(0))
411 (_ILIT(0)) (_ILIT(0))
413 tickLambda :: Id -> SaM ()
414 tickCases :: [CoreBndr] -> SaM ()
415 tickLet :: Id -> SaM ()
417 #ifndef OMIT_STRANAL_STATS
418 type SaM a = State SaStats a
420 tickLambda var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
421 -> case (tick_demanded var (0,0)) of { (totB, demandedB) ->
422 let tot = iUnbox totB ; demanded = iUnbox demandedB
423 in SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet)
425 tickCases vars = modify $ \(SaStats tlam dlam tc dc tlet dlet)
426 = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
427 let tot = iUnbox totB ; demanded = iUnbox demandedB
428 in SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet)
430 tickLet var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
431 = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
432 let tot = iUnbox totB ; demanded = iUnbox demandedB
433 in SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded))
435 tick_demanded var (tot, demanded)
436 | isTyVar var = (tot, demanded)
439 if (isStrict (idDemandInfo var))
443 pp_stats (SaStats tlam dlam tc dc tlet dlet)
444 = hcat [ptext (sLit "Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
445 ptext (sLit "; Case vars: "), int (iBox dc), char '/', int (iBox tc),
446 ptext (sLit "; Let vars: "), int (iBox dlet), char '/', int (iBox tlet)
449 #else /* OMIT_STRANAL_STATS */
451 newtype SaM a = SaM { unSaM :: a }
453 instance Monad SaM where
457 tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
458 tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
459 tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
461 #endif /* OMIT_STRANAL_STATS */
463 #endif /* OLD_STRICTNESS */