192dc8ad03e0e8290e63d7410c3223e43f8f5dea
[ghc-hetmet.git] / ghc / compiler / stranal / SaAbsInt.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[SaAbsInt]{Abstract interpreter for strictness analysis}
5
6 \begin{code}
7 #ifndef DEBUG
8 -- If DEBUG is off, omit all exports 
9 module SaAbsInt () where
10
11 #else
12 module SaAbsInt (
13         findStrictness,
14         findDemand, findDemandAlts,
15         absEval,
16         widen,
17         fixpoint,
18         isBot
19     ) where
20 #endif /* DEBUG */
21 #include "HsVersions.h"
22
23 import CmdLineOpts      ( opt_AllStrict, opt_NumbersStrict )
24 import CoreSyn
25 import CoreUnfold       ( maybeUnfoldingTemplate )
26 import Id               ( Id, idType, idStrictness, idUnfolding, isDataConId_maybe )
27 import DataCon          ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
28 import IdInfo           ( StrictnessInfo(..) )
29 import Demand           ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
30                           mkStrictnessInfo, isLazy
31                         )
32 import SaLib
33 import TyCon            ( isProductTyCon, isRecursiveTyCon )
34 import Type             ( splitTyConApp_maybe, 
35                           isUnLiftedType, Type )
36 import TyCon            ( tyConUnique )
37 import PrelInfo         ( numericTyKeys )
38 import Util             ( isIn, nOfThem, zipWithEqual )
39 import Outputable       
40 \end{code}
41
42 %************************************************************************
43 %*                                                                      *
44 \subsection[AbsVal-ops]{Operations on @AbsVals@}
45 %*                                                                      *
46 %************************************************************************
47
48 Least upper bound, greatest lower bound.
49
50 \begin{code}
51 lub, glb :: AbsVal -> AbsVal -> AbsVal
52
53 lub AbsBot val2   = val2        
54 lub val1   AbsBot = val1        
55
56 lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
57
58 lub _             _           = AbsTop  -- Crude, but conservative
59                                         -- The crudity only shows up if there
60                                         -- are functions involved
61
62 -- Slightly funny glb; for absence analysis only;
63 -- AbsBot is the safe answer.
64 --
65 -- Using anyBot rather than just testing for AbsBot is important.
66 -- Consider:
67 --
68 --   f = \a b -> ...
69 --
70 --   g = \x y z -> case x of
71 --                   []     -> f x
72 --                   (p:ps) -> f p
73 --
74 -- Now, the abstract value of the branches of the case will be an
75 -- AbsFun, but when testing for z's absence we want to spot that it's
76 -- an AbsFun which can't possibly return AbsBot.  So when glb'ing we
77 -- mustn't be too keen to bale out and return AbsBot; the anyBot test
78 -- spots that (f x) can't possibly return AbsBot.
79
80 -- We have also tripped over the following interesting case:
81 --      case x of
82 --        []     -> \y -> 1
83 --        (p:ps) -> f
84 --
85 -- Now, suppose f is bound to AbsTop.  Does this expression mention z?
86 -- Obviously not.  But the case will take the glb of AbsTop (for f) and
87 -- an AbsFun (for \y->1). We should not bale out and give AbsBot, because
88 -- that would say that it *does* mention z (or anything else for that matter).
89 -- Nor can we always return AbsTop, because the AbsFun might be something
90 -- like (\y->z), which obviously does mention z. The point is that we're
91 -- glbing two functions, and AbsTop is not actually the top of the function
92 -- lattice.  It is more like (\xyz -> x|y|z); that is, AbsTop returns
93 -- poison iff any of its arguments do.
94
95 -- Deal with functions specially, because AbsTop isn't the
96 -- top of their domain.
97
98 glb v1 v2
99   | is_fun v1 || is_fun v2
100   = if not (anyBot v1) && not (anyBot v2)
101     then
102         AbsTop
103     else
104         AbsBot
105   where
106     is_fun (AbsFun _ _)       = True
107     is_fun (AbsApproxFun _ _) = True    -- Not used, but the glb works ok
108     is_fun other              = False
109
110 -- The non-functional cases are quite straightforward
111
112 glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys)
113
114 glb AbsTop       v2           = v2
115 glb v1           AbsTop       = v1
116
117 glb _            _            = AbsBot          -- Be pessimistic
118 \end{code}
119
120 @isBot@ returns True if its argument is (a representation of) bottom.  The
121 ``representation'' part is because we need to detect the bottom {\em function}
122 too.  To detect the bottom function, bind its args to top, and see if it
123 returns bottom.
124
125 Used only in strictness analysis:
126 \begin{code}
127 isBot :: AbsVal -> Bool
128
129 isBot AbsBot = True
130 isBot other  = False    -- Functions aren't bottom any more
131 \end{code}
132
133 Used only in absence analysis:
134
135 \begin{code}
136 anyBot :: AbsVal -> Bool
137
138 anyBot AbsBot                  = True   -- poisoned!
139 anyBot AbsTop                  = False
140 anyBot (AbsProd vals)          = any anyBot vals
141 anyBot (AbsFun bndr_ty abs_fn) = anyBot (abs_fn AbsTop)
142 anyBot (AbsApproxFun _ val)    = anyBot val
143 \end{code}
144
145 @widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
146 approximated by $val$.  Furthermore, the result has no @AbsFun@s in
147 it, so it can be compared for equality by @sameVal@.
148
149 \begin{code}
150 widen :: AnalysisKind -> AbsVal -> AbsVal
151
152 -- Widening is complicated by the fact that funtions are lifted
153 widen StrAnal the_fn@(AbsFun bndr_ty _)
154   = case widened_body of
155         AbsApproxFun ds val -> AbsApproxFun (d : ds) val
156                             where
157                                d = findRecDemand str_fn abs_fn bndr_ty
158                                str_fn val = isBot (foldl (absApply StrAnal) the_fn 
159                                                          (val : [AbsTop | d <- ds]))
160
161         other               -> AbsApproxFun [d] widened_body
162                             where
163                                d = findRecDemand str_fn abs_fn bndr_ty
164                                str_fn val = isBot (absApply StrAnal the_fn val)
165   where
166     widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop)
167     abs_fn val   = False        -- Always says poison; so it looks as if
168                                 -- nothing is absent; safe
169
170 {-      OLD comment... 
171         This stuff is now instead handled neatly by the fact that AbsApproxFun 
172         contains an AbsVal inside it.   SLPJ Jan 97
173
174   | isBot abs_body = AbsBot
175     -- It's worth checking for a function which is unconditionally
176     -- bottom.  Consider
177     --
178     --  f x y = let g y = case x of ...
179     --          in (g ..) + (g ..)
180     --
181     -- Here, when we are considering strictness of f in x, we'll
182     -- evaluate the body of f with x bound to bottom.  The current
183     -- strategy is to bind g to its *widened* value; without the isBot
184     -- (...) test above, we'd bind g to an AbsApproxFun, and deliver
185     -- Top, not Bot as the value of f's rhs.  The test spots the
186     -- unconditional bottom-ness of g when x is bottom.  (Another
187     -- alternative here would be to bind g to its exact abstract
188     -- value, but that entails lots of potential re-computation, at
189     -- every application of g.)
190 -}
191
192 widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
193 widen StrAnal other_val      = other_val
194
195
196 widen AbsAnal the_fn@(AbsFun bndr_ty _)
197   | anyBot widened_body = AbsBot
198         -- In the absence-analysis case it's *essential* to check
199         -- that the function has no poison in its body.  If it does,
200         -- anywhere, then the whole function is poisonous.
201
202   | otherwise
203   = case widened_body of
204         AbsApproxFun ds val -> AbsApproxFun (d : ds) val
205                             where
206                                d = findRecDemand str_fn abs_fn bndr_ty
207                                abs_fn val = not (anyBot (foldl (absApply AbsAnal) the_fn 
208                                                                 (val : [AbsTop | d <- ds])))
209
210         other               -> AbsApproxFun [d] widened_body
211                             where
212                                d = findRecDemand str_fn abs_fn bndr_ty
213                                abs_fn val = not (anyBot (absApply AbsAnal the_fn val))
214   where
215     widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop)
216     str_fn val   = True         -- Always says non-termination;
217                                 -- that'll make findRecDemand peer into the
218                                 -- structure of the value.
219
220 widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
221
222         -- It's desirable to do a good job of widening for product
223         -- values.  Consider
224         --
225         --      let p = (x,y)
226         --      in ...(case p of (x,y) -> x)...
227         --
228         -- Now, is y absent in this expression?  Currently the
229         -- analyser widens p before looking at p's scope, to avoid
230         -- lots of recomputation in the case where p is a function.
231         -- So if widening doesn't have a case for products, we'll
232         -- widen p to AbsBot (since when searching for absence in y we
233         -- bind y to poison ie AbsBot), and now we are lost.
234
235 widen AbsAnal other_val = other_val
236
237 -- WAS:   if anyBot val then AbsBot else AbsTop
238 -- Nowadays widen is doing a better job on functions for absence analysis.
239 \end{code}
240
241 @crudeAbsWiden@ is used just for absence analysis, and always
242 returns AbsTop or AbsBot, so it widens to a two-point domain
243
244 \begin{code}
245 crudeAbsWiden :: AbsVal -> AbsVal
246 crudeAbsWiden val = if anyBot val then AbsBot else AbsTop
247 \end{code}
248
249 @sameVal@ compares two abstract values for equality.  It can't deal with
250 @AbsFun@, but that should have been removed earlier in the day by @widen@.
251
252 \begin{code}
253 sameVal :: AbsVal -> AbsVal -> Bool     -- Can't handle AbsFun!
254
255 #ifdef DEBUG
256 sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1"
257 sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2"
258 #endif
259
260 sameVal AbsBot AbsBot = True
261 sameVal AbsBot other  = False   -- widen has reduced AbsFun bots to AbsBot
262
263 sameVal AbsTop AbsTop = True
264 sameVal AbsTop other  = False           -- Right?
265
266 sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2)
267 sameVal (AbsProd _)     AbsTop          = False
268 sameVal (AbsProd _)     AbsBot          = False
269
270 sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v2
271 sameVal (AbsApproxFun _ _)     AbsTop                 = False
272 sameVal (AbsApproxFun _ _)     AbsBot                 = False
273
274 sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
275 \end{code}
276
277
278 @evalStrictness@ compares a @Demand@ with an abstract value, returning
279 @True@ iff the abstract value is {\em less defined} than the demand.
280 (@True@ is the exciting answer; @False@ is always safe.)
281
282 \begin{code}
283 evalStrictness :: Demand
284                -> AbsVal
285                -> Bool          -- True iff the value is sure
286                                 -- to be less defined than the Demand
287
288 evalStrictness (WwLazy _) _   = False
289 evalStrictness WwStrict   val = isBot val
290 evalStrictness WwEnum     val = isBot val
291
292 evalStrictness (WwUnpack _ demand_info) val
293   = case val of
294       AbsTop       -> False
295       AbsBot       -> True
296       AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
297       _            -> pprTrace "evalStrictness?" empty False
298
299 evalStrictness WwPrim val
300   = case val of
301       AbsTop -> False
302       AbsBot -> True    -- Can happen: consider f (g x), where g is a 
303                         -- recursive function returning an Int# that diverges
304
305       other  -> pprPanic "evalStrictness: WwPrim:" (ppr other)
306 \end{code}
307
308 For absence analysis, we're interested in whether "poison" in the
309 argument (ie a bottom therein) can propagate to the result of the
310 function call; that is, whether the specified demand can {\em
311 possibly} hit poison.
312
313 \begin{code}
314 evalAbsence (WwLazy True) _ = False     -- Can't possibly hit poison
315                                         -- with Absent demand
316
317 evalAbsence (WwUnpack _ demand_info) val
318   = case val of
319         AbsTop       -> False           -- No poison in here
320         AbsBot       -> True            -- Pure poison
321         AbsProd vals 
322            | length vals /= length demand_info -> pprTrace "evalAbsence" (ppr demand_info $$ ppr val)
323                                                   True
324            | otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
325         _              -> panic "evalAbsence: other"
326
327 evalAbsence other val = anyBot val
328   -- The demand is conservative; even "Lazy" *might* evaluate the
329   -- argument arbitrarily so we have to look everywhere for poison
330 \end{code}
331
332 %************************************************************************
333 %*                                                                      *
334 \subsection[absEval]{Evaluate an expression in the abstract domain}
335 %*                                                                      *
336 %************************************************************************
337
338 \begin{code}
339 -- The isBottomingId stuf is now dealt with via the Id's strictness info
340 -- absId anal var env | isBottomingId var
341 --   = case anal of
342 --      StrAnal -> AbsBot       -- See discussion below
343 --      AbsAnal -> AbsTop       -- Just want to see if there's any poison in
344                                 -- error's arg
345
346 absId anal var env
347   = case (lookupAbsValEnv env var, 
348           isDataConId_maybe var, 
349           idStrictness var, 
350           maybeUnfoldingTemplate (idUnfolding var)) of
351
352         (Just abs_val, _, _, _) ->
353                         abs_val -- Bound in the environment
354
355         (_, Just data_con, _, _) | isProductTyCon tycon &&
356                                    not (isRecursiveTyCon tycon)
357                 ->      -- A product.  We get infinite loops if we don't
358                         -- check for recursive products!
359                         -- The strictness info on the constructor 
360                         -- isn't expressive enough to contain its abstract value
361                    productAbsVal (dataConRepArgTys data_con) []
362                 where
363                    tycon = dataConTyCon data_con
364
365         (_, _, NoStrictnessInfo, Just unfolding) ->
366                         -- We have an unfolding for the expr
367                         -- Assume the unfolding has no free variables since it
368                         -- came from inside the Id
369                         absEval anal unfolding env
370                 -- Notice here that we only look in the unfolding if we don't
371                 -- have strictness info (an unusual situation).
372                 -- We could have chosen to look in the unfolding if it exists,
373                 -- and only try the strictness info if it doesn't, and that would
374                 -- give more accurate results, at the cost of re-abstract-interpreting
375                 -- the unfolding every time.
376                 -- We found only one place where the look-at-unfolding-first
377                 -- method gave better results, which is in the definition of
378                 -- showInt in the Prelude.  In its defintion, fromIntegral is
379                 -- not inlined (it's big) but ab-interp-ing its unfolding gave
380                 -- a better result than looking at its strictness only.
381                 --  showInt :: Integral a => a -> [Char] -> [Char]
382                 -- !       {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
383                 --         "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-}
384                 -- --- 42,44 ----
385                 --   showInt :: Integral a => a -> [Char] -> [Char]
386                 -- !       {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
387                 --        "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
388
389
390         (_, _, strictness_info, _) ->
391                         -- Includes NoUnfolding
392                         -- Try the strictness info
393                         absValFromStrictness anal strictness_info
394
395 productAbsVal []                 rev_abs_args = AbsProd (reverse rev_abs_args)
396 productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args))
397 \end{code}
398
399 \begin{code}
400 absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
401
402 absEval anal (Type ty) env = AbsTop
403 absEval anal (Var var) env = absId anal var env
404 \end{code}
405
406 Discussion about error (following/quoting Lennart): Any expression
407 'error e' is regarded as bottom (with HBC, with the -ffail-strict
408 flag, on with -O).
409
410 Regarding it as bottom gives much better strictness properties for
411 some functions.  E.g.
412
413         f [x] y = x+y
414         f (x:xs) y = f xs (x+y)
415 i.e.
416         f [] _ = error "no match"
417         f [x] y = x+y
418         f (x:xs) y = f xs (x+y)
419
420 is strict in y, which you really want.  But, it may lead to
421 transformations that turn a call to \tr{error} into non-termination.
422 (The odds of this happening aren't good.)
423
424 Things are a little different for absence analysis, because we want
425 to make sure that any poison (?????)
426
427 \begin{code}
428 absEval anal (Lit _) env = AbsTop
429         -- Literals terminate (strictness) and are not poison (absence)
430 \end{code}
431
432 \begin{code}
433 absEval anal (Lam bndr body) env
434   | isTyVar bndr = absEval anal body env        -- Type lambda
435   | otherwise    = AbsFun (idType bndr) abs_fn  -- Value lambda
436   where
437     abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg)
438
439 absEval anal (App expr (Type ty)) env
440   = absEval anal expr env                       -- Type appplication
441 absEval anal (App f val_arg) env
442   = absApply anal (absEval anal f env)          -- Value applicationn
443                   (absEval anal val_arg env)
444 \end{code}
445
446 \begin{code}
447 absEval anal expr@(Case scrut case_bndr alts) env
448   = let
449         scrut_val  = absEval anal scrut env
450         alts_env   = addOneToAbsValEnv env case_bndr scrut_val
451     in
452     case (scrut_val, alts) of
453         (AbsBot, _) -> AbsBot
454
455         (AbsProd arg_vals, [(con, bndrs, rhs)])
456                 | con /= DEFAULT ->
457                 -- The scrutinee is a product value, so it must be of a single-constr
458                 -- type; so the constructor in this alternative must be the right one
459                 -- so we can go ahead and bind the constructor args to the components
460                 -- of the product value.
461             ASSERT(length arg_vals == length val_bndrs)
462             absEval anal rhs rhs_env
463           where
464             val_bndrs = filter isId bndrs
465             rhs_env   = growAbsValEnvList alts_env (val_bndrs `zip` arg_vals)
466
467         other -> absEvalAlts anal alts alts_env
468 \end{code}
469
470 For @Lets@ we widen the value we get.  This is nothing to
471 do with fixpointing.  The reason is so that we don't get an explosion
472 in the amount of computation.  For example, consider:
473 \begin{verbatim}
474       let
475         g a = case a of
476                 q1 -> ...
477                 q2 -> ...
478         f x = case x of
479                 p1 -> ...g r...
480                 p2 -> ...g s...
481       in
482         f e
483 \end{verbatim}
484 If we bind @f@ and @g@ to their exact abstract value, then we'll
485 ``execute'' one call to @f@ and {\em two} calls to @g@.  This can blow
486 up exponentially.  Widening cuts it off by making a fixed
487 approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are
488 not evaluated again at all when they are called.
489
490 Of course, this can lose useful joint strictness, which is sad.  An
491 alternative approach would be to try with a certain amount of ``fuel''
492 and be prepared to bale out.
493
494 \begin{code}
495 absEval anal (Let (NonRec binder e1) e2) env
496   = let
497         new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
498     in
499         -- The binder of a NonRec should *not* be of unboxed type,
500         -- hence no need to strictly evaluate the Rhs.
501     absEval anal e2 new_env
502
503 absEval anal (Let (Rec pairs) body) env
504   = let
505         (binders,rhss) = unzip pairs
506         rhs_vals = cheapFixpoint anal binders rhss env  -- Returns widened values
507         new_env  = growAbsValEnvList env (binders `zip` rhs_vals)
508     in
509     absEval anal body new_env
510
511 absEval anal (Note (Coerce _ _) expr) env = AbsTop
512         -- Don't look inside coerces, becuase they
513         -- are usually recursive newtypes
514         -- (Could improve, for the error case, but we're about
515         -- to kill this analyser anyway.)
516 absEval anal (Note note expr) env = absEval anal expr env
517 \end{code}
518
519 \begin{code}
520 absEvalAlts :: AnalysisKind -> [CoreAlt] -> AbsValEnv -> AbsVal
521 absEvalAlts anal alts env
522   = combine anal (map go alts)
523   where
524     combine StrAnal = foldr1 lub        -- Diverge only if all diverge
525     combine AbsAnal = foldr1 glb        -- Find any poison
526
527     go (con, bndrs, rhs)
528       = absEval anal rhs rhs_env
529       where
530         rhs_env = growAbsValEnvList env (filter isId bndrs `zip` repeat AbsTop)
531 \end{code}
532
533 %************************************************************************
534 %*                                                                      *
535 \subsection[absApply]{Apply an abstract function to an abstract argument}
536 %*                                                                      *
537 %************************************************************************
538
539 Easy ones first:
540
541 \begin{code}
542 absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal
543
544 absApply anal AbsBot arg = AbsBot
545   -- AbsBot represents the abstract bottom *function* too
546
547 absApply StrAnal AbsTop arg = AbsTop
548 absApply AbsAnal AbsTop arg = if anyBot arg
549                               then AbsBot
550                               else AbsTop
551         -- To be conservative, we have to assume that a function about
552         -- which we know nothing (AbsTop) might look at some part of
553         -- its argument
554 \end{code}
555
556 An @AbsFun@ with only one more argument needed---bind it and eval the
557 result.  A @Lam@ with two or more args: return another @AbsFun@ with
558 an augmented environment.
559
560 \begin{code}
561 absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg
562 \end{code}
563
564 \begin{code}
565 absApply StrAnal (AbsApproxFun (d:ds) val) arg
566   = case ds of 
567         []    -> val'
568         other -> AbsApproxFun ds val'   -- Result is non-bot if there are still args
569   where
570     val' | evalStrictness d arg = AbsBot
571          | otherwise            = val
572
573 absApply AbsAnal (AbsApproxFun (d:ds) val) arg
574   = if evalAbsence d arg
575     then AbsBot         -- Poison in arg means poison in the application
576     else case ds of
577                 []    -> val
578                 other -> AbsApproxFun ds val
579
580 #ifdef DEBUG
581 absApply anal f@(AbsProd _) arg 
582   = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
583 #endif
584 \end{code}
585
586
587
588
589 %************************************************************************
590 %*                                                                      *
591 \subsection[findStrictness]{Determine some binders' strictness}
592 %*                                                                      *
593 %************************************************************************
594
595 \begin{code}
596 findStrictness :: Id
597                -> AbsVal                -- Abstract strictness value of function
598                -> AbsVal                -- Abstract absence value of function
599                -> StrictnessInfo        -- Resulting strictness annotation
600
601 findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _)
602         -- You might think there's really no point in describing detailed
603         -- strictness for a divergent function; 
604         -- If it's fully applied we get bottom regardless of the
605         -- argument.  If it's not fully applied we don't get bottom.
606         -- Finally, we don't want to regard the args of a divergent function
607         -- as 'interesting' for inlining purposes (see Simplify.prepareArgs)
608         --
609         -- HOWEVER, if we make diverging functions appear lazy, they
610         -- don't get wrappers, and then we get dreadful reboxing.
611         -- See notes with WwLib.worthSplitting
612   = find_strictness id str_ds str_res abs_ds
613
614 findStrictness id str_val abs_val 
615   | isBot str_val = mkStrictnessInfo ([], True)
616   | otherwise     = NoStrictnessInfo
617
618 -- The list of absence demands passed to combineDemands 
619 -- can be shorter than the list of absence demands
620 --
621 --      lookup = \ dEq -> letrec {
622 --                           lookup = \ key ds -> ...lookup...
623 --                        }
624 --                        in lookup
625 -- Here the strictness value takes three args, but the absence value
626 -- takes only one, for reasons I don't quite understand (see cheapFixpoint)
627
628 find_strictness id orig_str_ds orig_str_res orig_abs_ds
629   = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot)
630   where
631     res_bot = isBot orig_str_res
632
633     go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy)
634
635     mk_dmd str_dmd (WwLazy True)
636          = WARN( not (res_bot || isLazy str_dmd),
637                  ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds )
638                 -- If the arg isn't used we jolly well don't expect the function
639                 -- to be strict in it.  Unless the function diverges.
640            WwLazy True  -- Best of all
641
642     mk_dmd (WwUnpack u str_ds) 
643            (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds)
644
645     mk_dmd str_dmd abs_dmd = str_dmd
646 \end{code}
647
648
649 \begin{code}
650 findDemand dmd str_env abs_env expr binder
651   = findRecDemand str_fn abs_fn (idType binder)
652   where
653     str_fn val = evalStrictness   dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val))
654     abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)))
655
656 findDemandAlts dmd str_env abs_env alts binder
657   = findRecDemand str_fn abs_fn (idType binder)
658   where
659     str_fn val = evalStrictness   dmd (absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val))
660     abs_fn val = not (evalAbsence dmd (absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val)))
661 \end{code}
662
663 @findRecDemand@ is where we finally convert strictness/absence info
664 into ``Demands'' which we can pin on Ids (etc.).
665
666 NOTE: What do we do if something is {\em both} strict and absent?
667 Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all
668 strict (because of bottoming effect of \tr{error}) or all absent
669 (because they're not used)?
670
671 Well, for practical reasons, we prefer absence over strictness.  In
672 particular, it makes the ``default defaults'' for class methods (the
673 ones that say \tr{defm.foo dict = error "I don't exist"}) come out
674 nicely [saying ``the dict isn't used''], rather than saying it is
675 strict in every component of the dictionary [massive gratuitious
676 casing to take the dict apart].
677
678 But you could have examples where going for strictness would be better
679 than absence.  Consider:
680 \begin{verbatim}
681         let x = something big
682         in
683         f x y z + g x
684 \end{verbatim}
685
686 If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is
687 lazy, then the thunk for \tr{x} will be built.  If \tr{f} was strict,
688 then we'd let-to-case it:
689 \begin{verbatim}
690         case something big of
691           x -> f x y z + g x
692 \end{verbatim}
693 Ho hum.
694
695 \begin{code}
696 findRecDemand :: (AbsVal -> Bool)       -- True => function applied to this value yields Bot
697               -> (AbsVal -> Bool)       -- True => function applied to this value yields no poison
698               -> Type       -- The type of the argument
699               -> Demand
700
701 findRecDemand str_fn abs_fn ty
702   = if isUnLiftedType ty then -- It's a primitive type!
703        wwPrim
704
705     else if abs_fn AbsBot then -- It's absent
706        -- We prefer absence over strictness: see NOTE above.
707        WwLazy True
708
709     else if not (opt_AllStrict ||
710                  (opt_NumbersStrict && is_numeric_type ty) ||
711                  str_fn AbsBot) then
712         WwLazy False -- It's not strict and we're not pretending
713
714     else -- It's strict (or we're pretending it is)!
715
716        case splitProductType_maybe ty of
717
718          Nothing -> wwStrict    -- Could have a test for wwEnum, but
719                                 -- we don't exploit it yet, so don't bother
720
721          Just (tycon,_,data_con,cmpnt_tys)      -- Single constructor case
722            | isRecursiveTyCon tycon             -- Recursive data type; don't unpack
723            ->   wwStrict                        --      (this applies to newtypes too:
724                                                 --      e.g.  data Void = MkVoid Void)
725
726            |  null compt_strict_infos           -- A nullary data type
727            ->   wwStrict
728
729            | otherwise                          -- Some other data type
730            ->   wwUnpack compt_strict_infos
731
732            where
733               prod_len = length cmpnt_tys
734               compt_strict_infos
735                 = [ findRecDemand
736                          (\ cmpnt_val ->
737                                str_fn (mkMainlyTopProd prod_len i cmpnt_val)
738                          )
739                          (\ cmpnt_val ->
740                                abs_fn (mkMainlyTopProd prod_len i cmpnt_val)
741                          )
742                      cmpnt_ty
743                   | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
744
745   where
746     is_numeric_type ty
747       = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above
748           Nothing         -> False
749           Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys
750       where
751         is_elem = isIn "is_numeric_type"
752
753     -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of
754     -- them) except for a given value in the "i"th position.
755
756     mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal
757
758     mkMainlyTopProd n i val
759       = let
760             befores = nOfThem (i-1) AbsTop
761             afters  = nOfThem (n-i) AbsTop
762         in
763         AbsProd (befores ++ (val : afters))
764 \end{code}
765
766 %************************************************************************
767 %*                                                                      *
768 \subsection[fixpoint]{Fixpointer for the strictness analyser}
769 %*                                                                      *
770 %************************************************************************
771
772 The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an
773 environment, and returns the abstract value of each binder.
774
775 The @cheapFixpoint@ function makes a conservative approximation,
776 by binding each of the variables to Top in their own right hand sides.
777 That allows us to make rapid progress, at the cost of a less-than-wonderful
778 approximation.
779
780 \begin{code}
781 cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
782
783 cheapFixpoint AbsAnal [id] [rhs] env
784   = [crudeAbsWiden (absEval AbsAnal rhs new_env)]
785   where
786     new_env = addOneToAbsValEnv env id AbsTop   -- Unsafe starting point!
787                     -- In the just-one-binding case, we guarantee to
788                     -- find a fixed point in just one iteration,
789                     -- because we are using only a two-point domain.
790                     -- This improves matters in cases like:
791                     --
792                     --  f x y = letrec g = ...g...
793                     --          in g x
794                     --
795                     -- Here, y isn't used at all, but if g is bound to
796                     -- AbsBot we simply get AbsBot as the next
797                     -- iteration too.
798
799 cheapFixpoint anal ids rhss env
800   = [widen anal (absEval anal rhs new_env) | rhs <- rhss]
801                 -- We do just one iteration, starting from a safe
802                 -- approximation.  This won't do a good job in situations
803                 -- like:
804                 --      \x -> letrec f = ...g...
805                 --                   g = ...f...x...
806                 --            in
807                 --            ...f...
808                 -- Here, f will end up bound to Top after one iteration,
809                 -- and hence we won't spot the strictness in x.
810                 -- (A second iteration would solve this.  ToDo: try the effect of
811                 --  really searching for a fixed point.)
812   where
813     new_env = growAbsValEnvList env [(id,safe_val) | id <- ids]
814
815     safe_val
816       = case anal of    -- The safe starting point
817           StrAnal -> AbsTop
818           AbsAnal -> AbsBot
819 \end{code}
820
821 \begin{code}
822 fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
823
824 fixpoint anal [] _ env = []
825
826 fixpoint anal ids rhss env
827   = fix_loop initial_vals
828   where
829     initial_val id
830       = case anal of    -- The (unsafe) starting point
831           AbsAnal -> AbsTop
832           StrAnal -> AbsBot
833                 -- At one stage for StrAnal we said:
834                 --   if (returnsRealWorld (idType id))
835                 --   then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
836                 -- but no one has the foggiest idea what this hack did,
837                 -- and returnsRealWorld was a stub that always returned False
838                 -- So this comment is all that is left of the hack!
839
840     initial_vals = [ initial_val id | id <- ids ]
841
842     fix_loop :: [AbsVal] -> [AbsVal]
843
844     fix_loop current_widened_vals
845       = let
846             new_env  = growAbsValEnvList env (ids `zip` current_widened_vals)
847             new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
848             new_widened_vals = map (widen anal) new_vals
849         in
850         if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
851             current_widened_vals
852
853             -- NB: I was too chicken to make that a zipWithEqual,
854             -- lest I jump into a black hole.  WDP 96/02
855
856             -- Return the widened values.  We might get a slightly
857             -- better value by returning new_vals (which we used to
858             -- do, see below), but alas that means that whenever the
859             -- function is called we have to re-execute it, which is
860             -- expensive.
861
862             -- OLD VERSION
863             -- new_vals
864             -- Return the un-widened values which may be a bit better
865             -- than the widened ones, and are guaranteed safe, since
866             -- they are one iteration beyond current_widened_vals,
867             -- which itself is a fixed point.
868         else
869             fix_loop new_widened_vals
870 \end{code}
871
872 For absence analysis, we make do with a very very simple approach:
873 look for convergence in a two-point domain.
874
875 We used to use just one iteration, starting with the variables bound
876 to @AbsBot@, which is safe.
877
878 Prior to that, we used one iteration starting from @AbsTop@ (which
879 isn't safe).  Why isn't @AbsTop@ safe?  Consider:
880 \begin{verbatim}
881         letrec
882           x = ...p..d...
883           d = (x,y)
884         in
885         ...
886 \end{verbatim}
887 Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed
888 point'' of @d@ being @(AbsTop, AbsTop)@!  An @AbsBot@ initial value is
889 safe because it gives poison more often than really necessary, and
890 thus may miss some absence, but will never claim absence when it ain't
891 so.
892
893 Anyway, one iteration starting with everything bound to @AbsBot@ give
894 bad results for
895
896         f = \ x -> ...f...
897
898 Here, f would always end up bound to @AbsBot@, which ain't very
899 clever, because then it would introduce poison whenever it was
900 applied.  Much better to start with f bound to @AbsTop@, and widen it
901 to @AbsBot@ if any poison shows up. In effect we look for convergence
902 in the two-point @AbsTop@/@AbsBot@ domain.
903
904 What we miss (compared with the cleverer strictness analysis) is
905 spotting that in this case
906
907         f = \ x y -> ...y...(f x y')...
908
909 \tr{x} is actually absent, since it is only passed round the loop, never
910 used.  But who cares about missing that?
911
912 NB: despite only having a two-point domain, we may still have many
913 iterations, because there are several variables involved at once.