Fixed warnings in hsSyn/HsImpExp, except for incomplete pattern matches
[ghc-hetmet.git] / compiler / stranal / StrictAnal.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
5
6 The original version(s) of all strictness-analyser code (except the
7 Semantique analyser) was written by Andy Gill.
8
9 \begin{code}
10 {-# OPTIONS -w #-}
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
15 -- for details
16
17 #ifndef OLD_STRICTNESS
18 module StrictAnal ( ) where
19
20 #else
21
22 module StrictAnal ( saBinds ) where
23
24 #include "HsVersions.h"
25
26 import DynFlags ( DynFlags, DynFlag(..) )
27 import CoreSyn
28 import Id               ( setIdStrictness, setInlinePragma, 
29                           idDemandInfo, setIdDemandInfo, isBottomingId,
30                           Id
31                         )
32 import CoreLint         ( showPass, endPass )
33 import ErrUtils         ( dumpIfSet_dyn )
34 import SaAbsInt
35 import SaLib
36 import Demand           ( Demand, wwStrict, isStrict, isLazy )
37 import Util             ( zipWith3Equal, stretchZipWith, compareLength )
38 import BasicTypes       ( Activation( NeverActive ) )
39 import Outputable
40 import FastTypes
41 import State
42 \end{code}
43
44 %************************************************************************
45 %*                                                                      *
46 \subsection[Thoughts]{Random thoughts}
47 %*                                                                      *
48 %************************************************************************
49
50 A note about worker-wrappering.  If we have
51
52         f :: Int -> Int
53         f = let v = <expensive>
54             in \x -> <body>
55
56 and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
57
58         f = \x -> case x of Int x# -> fw x#
59         fw = \x# -> let x = Int x#
60                     in
61                     let v = <expensive>
62                     in <body>
63
64 because this obviously loses laziness, since now <expensive>
65 is done each time.  Alas.
66
67 WATCH OUT!  This can mean that something is unboxed only to be
68 boxed again. For example
69
70         g x y = f x
71
72 Here g is strict, and *will* split into worker-wrapper.  A call to
73 g, with the wrapper inlined will then be
74
75         case arg of Int a# -> gw a#
76
77 Now g calls f, which has no wrapper, so it has to box it.
78
79         gw = \a# -> f (Int a#)
80
81 Alas and alack.
82
83
84 %************************************************************************
85 %*                                                                      *
86 \subsection[iface-StrictAnal]{Interface to the outside world}
87 %*                                                                      *
88 %************************************************************************
89
90 @saBinds@ decorates bindings with strictness info.  A later 
91 worker-wrapper pass can use this info to create wrappers and
92 strict workers.
93
94 \begin{code}
95 saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
96 saBinds dflags binds
97   = do {
98         showPass dflags "Strictness analysis";
99
100         -- Mark each binder with its strictness
101 #ifndef OMIT_STRANAL_STATS
102         let { (binds_w_strictness, sa_stats) = runState $ (saTopBinds binds) nullSaStats };
103         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
104                   (pp_stats sa_stats);
105 #else
106         let { binds_w_strictness = unSaM $ saTopBindsBinds binds };
107 #endif
108
109         endPass dflags "Strictness analysis" Opt_D_dump_stranal
110                 binds_w_strictness
111     }
112 \end{code}
113
114 %************************************************************************
115 %*                                                                      *
116 \subsection[saBinds]{Strictness analysis of bindings}
117 %*                                                                      *
118 %************************************************************************
119
120 [Some of the documentation about types, etc., in \tr{SaLib} may be
121 helpful for understanding this module.]
122
123 @saTopBinds@ tags each binder in the program with its @Demand@.
124 That tells how each binder is {\em used}; if @Strict@, then the binder
125 is sure to be evaluated to HNF; if @NonStrict@ it may or may not be;
126 if @Absent@, then it certainly is not used. [DATED; ToDo: update]
127
128 (The above info is actually recorded for posterity in each binder's
129 IdInfo, notably its @DemandInfo@.)
130
131 We proceed by analysing the bindings top-to-bottom, building up an
132 environment which maps @Id@s to their abstract values (i.e., an
133 @AbsValEnv@ maps an @Id@ to its @AbsVal@).
134
135 \begin{code}
136 saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported
137
138 saTopBinds binds
139   = let
140         starting_abs_env = nullAbsValEnv
141     in
142     do_it starting_abs_env starting_abs_env binds
143   where
144     do_it _    _    [] = return []
145     do_it senv aenv (b:bs) = do
146         (senv2, aenv2, new_b) <- saTopBind senv  aenv  b
147         new_bs                <- do_it     senv2 aenv2 bs
148         return (new_b : new_bs)
149 \end{code}
150
151 @saTopBind@ is only used for the top level.  We don't add any demand
152 info to these ids because we can't work it out.  In any case, it
153 doesn't do us any good to know whether top-level binders are sure to
154 be used; we can't turn top-level @let@s into @case@s.
155
156 \begin{code}
157 saTopBind :: StrictEnv -> AbsenceEnv
158           -> CoreBind
159           -> SaM (StrictEnv, AbsenceEnv, CoreBind)
160
161 saTopBind str_env abs_env (NonRec binder rhs) = do
162     new_rhs <- saExpr minDemand str_env abs_env rhs
163     let
164         str_rhs = absEval StrAnal rhs str_env
165         abs_rhs = absEval AbsAnal rhs abs_env
166
167         widened_str_rhs = widen StrAnal str_rhs
168         widened_abs_rhs = widen AbsAnal abs_rhs
169                 -- The widening above is done for efficiency reasons.
170                 -- See notes on Let case in SaAbsInt.lhs
171
172         new_binder
173           = addStrictnessInfoToTopId
174                 widened_str_rhs widened_abs_rhs
175                 binder
176
177           -- Augment environments with a mapping of the
178           -- binder to its abstract values, computed by absEval
179         new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
180         new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
181     
182     return (new_str_env, new_abs_env, NonRec new_binder new_rhs)
183
184 saTopBind str_env abs_env (Rec pairs)
185   = let
186         (binders,rhss) = unzip pairs
187         str_rhss    = fixpoint StrAnal binders rhss str_env
188         abs_rhss    = fixpoint AbsAnal binders rhss abs_env
189                       -- fixpoint returns widened values
190         new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
191         new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
192         new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId
193                                     str_rhss abs_rhss binders
194     
195     new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
196     let
197         new_pairs   = new_binders `zip` new_rhss
198     
199     return (new_str_env, new_abs_env, Rec new_pairs)
200
201 -- Hack alert!
202 -- Top level divergent bindings are marked NOINLINE
203 -- This avoids fruitless inlining of top level error functions
204 addStrictnessInfoToTopId str_val abs_val bndr
205   = if isBottomingId new_id then
206         new_id `setInlinePragma` NeverActive
207     else
208         new_id
209   where
210     new_id = addStrictnessInfoToId str_val abs_val bndr
211 \end{code}
212
213 %************************************************************************
214 %*                                                                      *
215 \subsection[saExpr]{Strictness analysis of an expression}
216 %*                                                                      *
217 %************************************************************************
218
219 @saExpr@ computes the strictness of an expression within a given
220 environment.
221
222 \begin{code}
223 saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
224         -- The demand is the least demand we expect on the
225         -- expression.  WwStrict is the least, because we're only
226         -- interested in the expression at all if it's being evaluated,
227         -- but the demand may be more.  E.g.
228         --      f E
229         -- where f has strictness u(LL), will evaluate E with demand u(LL)
230
231 minDemand = wwStrict 
232 minDemands = repeat minDemand
233
234 -- When we find an application, do the arguments
235 -- with demands gotten from the function
236 saApp str_env abs_env (fun, args) = do
237     args' <- sequence sa_args
238     fun' <- saExpr minDemand str_env abs_env fun
239     return (mkApps fun' args')
240   where
241     arg_dmds = case fun of
242                  Var var -> case lookupAbsValEnv str_env var of
243                                 Just (AbsApproxFun ds _) 
244                                    | compareLength ds args /= LT 
245                                               -- 'ds' is at least as long as 'args'.
246                                         -> ds ++ minDemands
247                                 other   -> minDemands
248                  other -> minDemands
249
250     sa_args = stretchZipWith isTypeArg (error "saApp:dmd") 
251                              sa_arg args arg_dmds 
252         -- The arg_dmds are for value args only, we need to skip
253         -- over the type args when pairing up with the demands
254         -- Hence the stretchZipWith
255
256     sa_arg arg dmd = saExpr dmd' str_env abs_env arg
257                    where
258                         -- Bring arg demand up to minDemand
259                         dmd' | isLazy dmd = minDemand
260                              | otherwise  = dmd
261
262 saExpr _ _ _ e@(Var _)  = return e
263 saExpr _ _ _ e@(Lit _)  = return e
264 saExpr _ _ _ e@(Type _) = return e
265
266 saExpr dmd str_env abs_env (Lam bndr body)
267   = do  -- Don't bother to set the demand-info on a lambda binder
268         -- We do that only for let(rec)-bound functions
269     new_body <- saExpr minDemand str_env abs_env body
270     return (Lam bndr new_body)
271
272 saExpr dmd str_env abs_env e@(App fun arg)
273   = saApp str_env abs_env (collectArgs e)
274
275 saExpr dmd str_env abs_env (Note note expr) = do
276     new_expr <- saExpr dmd str_env abs_env expr
277     return (Note note new_expr)
278
279 saExpr dmd str_env abs_env (Case expr case_bndr alts) = do
280     new_expr <- saExpr minDemand str_env abs_env expr
281     new_alts <- mapM sa_alt alts
282     let
283         new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr
284     return (Case new_expr new_case_bndr new_alts)
285   where
286     sa_alt (con, binders, rhs) = do
287         new_rhs <- saExpr dmd str_env abs_env rhs
288         let
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
292         
293         tickCases new_binders -- stats
294         return (con, new_binders, new_rhs)
295
296 saExpr dmd str_env abs_env (Let (NonRec binder rhs) body) = do
297         -- Analyse the RHS in the environment at hand
298     let
299         -- Find the demand on the RHS
300         rhs_dmd = findDemand dmd str_env abs_env body binder
301
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
306
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
311
312         new_str_env     = addOneToAbsValEnv str_env binder widened_str_rhs
313         new_abs_env     = addOneToAbsValEnv abs_env binder widened_abs_rhs
314
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)
320     
321     tickLet new_binder           -- stats
322     new_rhs <- saExpr rhs_dmd str_env abs_env rhs
323     new_body <- saExpr dmd new_str_env new_abs_env body
324     return (Let (NonRec new_binder new_rhs) new_body)
325
326 saExpr dmd str_env abs_env (Let (Rec pairs) body) = do
327     let
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)
334     
335     new_body <- saExpr dmd new_str_env new_abs_env body
336     new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss
337     let
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...
342 --                             y = ...x...
343 --                      in ...x...
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.
348
349         improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId
350                                          str_vals abs_vals binders
351
352         new_pairs   = improved_binders `zip` new_rhss
353     
354     return (Let (Rec new_pairs) new_body)
355 \end{code}
356
357
358 %************************************************************************
359 %*                                                                      *
360 \subsection[computeInfos]{Add computed info to binders}
361 %*                                                                      *
362 %************************************************************************
363
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.
371
372 A better idea might be to have some kind of arity analysis to
373 tell how many args could safely be grabbed.
374
375 \begin{code}
376 addStrictnessInfoToId
377         :: AbsVal               -- Abstract strictness value
378         -> AbsVal               -- Ditto absence
379         -> Id                   -- The id
380         -> Id                   -- Augmented with strictness
381
382 addStrictnessInfoToId str_val abs_val binder
383   = binder `setIdStrictness` findStrictness binder str_val abs_val
384 \end{code}
385
386 \begin{code}
387 addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv
388                   -> CoreExpr   -- The scope of the id
389                   -> Id
390                   -> Id                 -- Id augmented with Demand info
391
392 addDemandInfoToId dmd str_env abs_env expr binder
393   = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder)
394
395 addDemandInfoToCaseBndr dmd str_env abs_env alts binder
396   = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder)
397 \end{code}
398
399 %************************************************************************
400 %*                                                                      *
401 \subsection{Monad used herein for stats}
402 %*                                                                      *
403 %************************************************************************
404
405 \begin{code}
406 data SaStats
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)
411
412 nullSaStats = SaStats
413    (_ILIT(0)) (_ILIT(0))
414    (_ILIT(0)) (_ILIT(0))
415    (_ILIT(0)) (_ILIT(0))
416
417 tickLambda :: Id   -> SaM ()
418 tickCases  :: [CoreBndr] -> SaM ()
419 tickLet    :: Id   -> SaM ()
420
421 #ifndef OMIT_STRANAL_STATS
422 type SaM a = State SaStats a
423
424 tickLambda var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
425   -> case (tick_demanded var (0,0)) of { (totB, demandedB) ->
426      let tot = iUnbox totB ; demanded = iUnbox demandedB 
427      in SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet)
428
429 tickCases vars = modify $ \(SaStats tlam dlam tc dc tlet dlet)
430   = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
431     let tot = iUnbox totB ; demanded = iUnbox demandedB 
432     in  SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet)
433
434 tickLet var = modify $ \(SaStats tlam dlam tc dc tlet dlet)
435   = case (tick_demanded var (0,0))        of { (totB, demandedB) ->
436     let tot = iUnbox totB ; demanded = iUnbox demandedB 
437     in SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded))
438
439 tick_demanded var (tot, demanded)
440   | isTyVar var = (tot, demanded)
441   | otherwise
442   = (tot + 1,
443      if (isStrict (idDemandInfo var))
444      then demanded + 1
445      else demanded)
446
447 pp_stats (SaStats tlam dlam tc dc tlet dlet)
448       = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
449               ptext SLIT("; Case vars: "), int (iBox dc),   char '/', int (iBox tc),
450               ptext SLIT("; Let vars: "),  int (iBox dlet), char '/', int (iBox tlet)
451         ]
452
453 #else /* OMIT_STRANAL_STATS */
454 -- identity monad
455 newtype SaM a = SaM { unSaM :: a }
456
457 instance Monad SaM where
458     return x    = SaM x
459     SaM x >>= f = f x
460
461 tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
462 tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
463 tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
464
465 #endif /* OMIT_STRANAL_STATS */
466
467 #endif /* OLD_STRICTNESS */
468 \end{code}