[project @ 1998-04-24 09:48:20 by simonpj]
[ghc-hetmet.git] / ghc / compiler / stranal / SaAbsInt.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
3 %
4 \section[SaAbsInt]{Abstract interpreter for strictness analysis}
5
6 \begin{code}
7 module SaAbsInt (
8         findStrictness,
9         findDemand,
10         absEval,
11         widen,
12         fixpoint,
13         isBot
14     ) where
15
16 #include "HsVersions.h"
17
18 import CmdLineOpts      ( opt_AllStrict, opt_NumbersStrict )
19 import CoreSyn
20 import CoreUnfold       ( Unfolding(..), FormSummary )
21 import CoreUtils        ( unTagBinders )
22 import Id               ( idType, getIdStrictness, getIdUnfolding,
23                           dataConTyCon, dataConArgTys, Id
24                         )
25 import IdInfo           ( StrictnessInfo(..) )
26 import Demand           ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwUnpackNew )
27 import MagicUFs         ( MagicUnfoldingFun )
28 import Maybes           ( maybeToBool )
29 import PrimOp           ( PrimOp(..) )
30 import SaLib
31 import TyCon            ( isProductTyCon, isEnumerationTyCon, isNewTyCon, 
32                           TyCon{-instance Eq-}
33                         )
34 import BasicTypes       ( NewOrData(..) )
35 import Type             ( splitAlgTyConApp_maybe, 
36                           isUnpointedType, Type )
37 import TysWiredIn       ( intTyCon, integerTyCon, doubleTyCon,
38                           floatTyCon, wordTyCon, addrTyCon
39                         )
40 import Util             ( isIn, isn'tIn, nOfThem, zipWithEqual )
41 import GlaExts          ( trace )
42 import Outputable       
43
44 returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)"
45 \end{code}
46
47 %************************************************************************
48 %*                                                                      *
49 \subsection[AbsVal-ops]{Operations on @AbsVals@}
50 %*                                                                      *
51 %************************************************************************
52
53 Least upper bound, greatest lower bound.
54
55 \begin{code}
56 lub, glb :: AbsVal -> AbsVal -> AbsVal
57
58 lub val1 val2 | isBot val1    = val2    -- The isBot test includes the case where
59 lub val1 val2 | isBot val2    = val1    -- one of the val's is a function which
60                                         -- always returns bottom, such as \y.x,
61                                         -- when x is bound to bottom.
62
63 lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
64
65 lub _             _           = AbsTop  -- Crude, but conservative
66                                         -- The crudity only shows up if there
67                                         -- are functions involved
68
69 -- Slightly funny glb; for absence analysis only;
70 -- AbsBot is the safe answer.
71 --
72 -- Using anyBot rather than just testing for AbsBot is important.
73 -- Consider:
74 --
75 --   f = \a b -> ...
76 --
77 --   g = \x y z -> case x of
78 --                   []     -> f x
79 --                   (p:ps) -> f p
80 --
81 -- Now, the abstract value of the branches of the case will be an
82 -- AbsFun, but when testing for z's absence we want to spot that it's
83 -- an AbsFun which can't possibly return AbsBot.  So when glb'ing we
84 -- mustn't be too keen to bale out and return AbsBot; the anyBot test
85 -- spots that (f x) can't possibly return AbsBot.
86
87 -- We have also tripped over the following interesting case:
88 --      case x of
89 --        []     -> \y -> 1
90 --        (p:ps) -> f
91 --
92 -- Now, suppose f is bound to AbsTop.  Does this expression mention z?
93 -- Obviously not.  But the case will take the glb of AbsTop (for f) and
94 -- an AbsFun (for \y->1). We should not bale out and give AbsBot, because
95 -- that would say that it *does* mention z (or anything else for that matter).
96 -- Nor can we always return AbsTop, because the AbsFun might be something
97 -- like (\y->z), which obviously does mention z. The point is that we're
98 -- glbing two functions, and AbsTop is not actually the top of the function
99 -- lattice.  It is more like (\xyz -> x|y|z); that is, AbsTop returns
100 -- poison iff any of its arguments do.
101
102 -- Deal with functions specially, because AbsTop isn't the
103 -- top of their domain.
104
105 glb v1 v2
106   | is_fun v1 || is_fun v2
107   = if not (anyBot v1) && not (anyBot v2)
108     then
109         AbsTop
110     else
111         AbsBot
112   where
113     is_fun (AbsFun _ _ _)     = True
114     is_fun (AbsApproxFun _ _) = True    -- Not used, but the glb works ok
115     is_fun other              = False
116
117 -- The non-functional cases are quite straightforward
118
119 glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys)
120
121 glb AbsTop       v2           = v2
122 glb v1           AbsTop       = v1
123
124 glb _            _            = AbsBot          -- Be pessimistic
125
126
127
128 combineCaseValues
129         :: AnalysisKind
130         -> AbsVal       -- Value of scrutinee
131         -> [AbsVal]     -- Value of branches (at least one)
132         -> AbsVal       -- Result
133
134 -- For strictness analysis, see if the scrutinee is bottom; if so
135 -- return bottom; otherwise, the lub of the branches.
136
137 combineCaseValues StrAnal AbsBot          branches = AbsBot
138 combineCaseValues StrAnal other_scrutinee branches
139         -- Scrutinee can only be AbsBot, AbsProd or AbsTop
140   = ASSERT(ok_scrutinee)
141     foldr1 lub branches
142   where
143     ok_scrutinee
144       = case other_scrutinee of {
145           AbsTop    -> True;    -- i.e., cool
146           AbsProd _ -> True;    -- ditto
147           _         -> False    -- party over
148         }
149
150 -- For absence analysis, check if the scrutinee is all poison (isBot)
151 -- If so, return poison (AbsBot); otherwise, any nested poison will come
152 -- out from looking at the branches, so just glb together the branches
153 -- to get the worst one.
154
155 combineCaseValues AbsAnal AbsBot          branches = AbsBot
156 combineCaseValues AbsAnal other_scrutinee branches
157         -- Scrutinee can only be AbsBot, AbsProd or AbsTop
158   = ASSERT(ok_scrutinee)
159     let
160         result = foldr1 glb branches
161
162         tracer = if at_least_one_AbsFun && at_least_one_AbsTop
163                     && no_AbsBots then
164                     pprTrace "combineCase:" (ppr branches)
165                  else
166                     id
167     in
168 --    tracer (
169     result
170 --    )
171   where
172     ok_scrutinee
173       = case other_scrutinee of {
174           AbsTop    -> True;    -- i.e., cool
175           AbsProd _ -> True;    -- ditto
176           _         -> False    -- party over
177         }
178
179     at_least_one_AbsFun = foldr ((||) . is_AbsFun) False branches
180     at_least_one_AbsTop = foldr ((||) . is_AbsTop) False branches
181     no_AbsBots = foldr ((&&) . is_not_AbsBot) True branches
182
183     is_AbsFun x = case x of { AbsFun _ _ _ -> True; _ -> False }
184     is_AbsTop x = case x of { AbsTop -> True; _ -> False }
185     is_not_AbsBot x = case x of { AbsBot -> False; _ -> True }
186 \end{code}
187
188 @isBot@ returns True if its argument is (a representation of) bottom.  The
189 ``representation'' part is because we need to detect the bottom {\em function}
190 too.  To detect the bottom function, bind its args to top, and see if it
191 returns bottom.
192
193 Used only in strictness analysis:
194 \begin{code}
195 isBot :: AbsVal -> Bool
196
197 isBot AbsBot                = True
198 isBot (AbsFun arg body env) = isBot (absEval StrAnal body env)
199                                -- Don't bother to extend the envt because
200                                -- unbound variables default to AbsTop anyway
201 isBot other                 = False
202 \end{code}
203
204 Used only in absence analysis:
205 \begin{code}
206 anyBot :: AbsVal -> Bool
207
208 anyBot AbsBot                 = True    -- poisoned!
209 anyBot AbsTop                 = False
210 anyBot (AbsProd vals)         = any anyBot vals
211 anyBot (AbsFun arg body env)  = anyBot (absEval AbsAnal body env)
212 anyBot (AbsApproxFun _ _)     = False
213
214     -- AbsApproxFun can only arise in absence analysis from the Demand
215     -- info of an imported value; whatever it is we're looking for is
216     -- certainly not present over in the imported value.
217 \end{code}
218
219 @widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
220 approximated by $val$.  Furthermore, the result has no @AbsFun@s in
221 it, so it can be compared for equality by @sameVal@.
222
223 \begin{code}
224 widen :: AnalysisKind -> AbsVal -> AbsVal
225
226 widen StrAnal (AbsFun arg body env)
227   = AbsApproxFun (findDemandStrOnly env body arg)
228                  (widen StrAnal abs_body)
229   where
230     abs_body = absEval StrAnal body env
231
232 {-      OLD comment... 
233         This stuff is now instead handled neatly by the fact that AbsApproxFun 
234         contains an AbsVal inside it.   SLPJ Jan 97
235
236   | isBot abs_body = AbsBot
237     -- It's worth checking for a function which is unconditionally
238     -- bottom.  Consider
239     --
240     --  f x y = let g y = case x of ...
241     --          in (g ..) + (g ..)
242     --
243     -- Here, when we are considering strictness of f in x, we'll
244     -- evaluate the body of f with x bound to bottom.  The current
245     -- strategy is to bind g to its *widened* value; without the isBot
246     -- (...) test above, we'd bind g to an AbsApproxFun, and deliver
247     -- Top, not Bot as the value of f's rhs.  The test spots the
248     -- unconditional bottom-ness of g when x is bottom.  (Another
249     -- alternative here would be to bind g to its exact abstract
250     -- value, but that entails lots of potential re-computation, at
251     -- every application of g.)
252 -}
253
254 widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
255 widen StrAnal other_val      = other_val
256
257
258 widen AbsAnal (AbsFun arg body env)
259   | anyBot abs_body = AbsBot
260         -- In the absence-analysis case it's *essential* to check
261         -- that the function has no poison in its body.  If it does,
262         -- anywhere, then the whole function is poisonous.
263
264   | otherwise
265   = AbsApproxFun (findDemandAbsOnly env body arg)
266                  (widen AbsAnal abs_body)
267   where
268     abs_body = absEval AbsAnal body env
269
270 widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
271
272         -- It's desirable to do a good job of widening for product
273         -- values.  Consider
274         --
275         --      let p = (x,y)
276         --      in ...(case p of (x,y) -> x)...
277         --
278         -- Now, is y absent in this expression?  Currently the
279         -- analyser widens p before looking at p's scope, to avoid
280         -- lots of recomputation in the case where p is a function.
281         -- So if widening doesn't have a case for products, we'll
282         -- widen p to AbsBot (since when searching for absence in y we
283         -- bind y to poison ie AbsBot), and now we are lost.
284
285 widen AbsAnal other_val = other_val
286
287 -- WAS:   if anyBot val then AbsBot else AbsTop
288 -- Nowadays widen is doing a better job on functions for absence analysis.
289 \end{code}
290
291 @crudeAbsWiden@ is used just for absence analysis, and always
292 returns AbsTop or AbsBot, so it widens to a two-point domain
293
294 \begin{code}
295 crudeAbsWiden :: AbsVal -> AbsVal
296 crudeAbsWiden val = if anyBot val then AbsBot else AbsTop
297 \end{code}
298
299 @sameVal@ compares two abstract values for equality.  It can't deal with
300 @AbsFun@, but that should have been removed earlier in the day by @widen@.
301
302 \begin{code}
303 sameVal :: AbsVal -> AbsVal -> Bool     -- Can't handle AbsFun!
304
305 #ifdef DEBUG
306 sameVal (AbsFun _ _ _) _ = panic "sameVal: AbsFun: arg1"
307 sameVal _ (AbsFun _ _ _) = panic "sameVal: AbsFun: arg2"
308 #endif
309
310 sameVal AbsBot AbsBot = True
311 sameVal AbsBot other  = False   -- widen has reduced AbsFun bots to AbsBot
312
313 sameVal AbsTop AbsTop = True
314 sameVal AbsTop other  = False           -- Right?
315
316 sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2)
317 sameVal (AbsProd _)     AbsTop          = False
318 sameVal (AbsProd _)     AbsBot          = False
319
320 sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v2
321 sameVal (AbsApproxFun _ _)     AbsTop                 = False
322 sameVal (AbsApproxFun _ _)     AbsBot                 = False
323
324 sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
325 \end{code}
326
327
328 @evalStrictness@ compares a @Demand@ with an abstract value, returning
329 @True@ iff the abstract value is {\em less defined} than the demand.
330 (@True@ is the exciting answer; @False@ is always safe.)
331
332 \begin{code}
333 evalStrictness :: Demand
334                -> AbsVal
335                -> Bool          -- True iff the value is sure
336                                 -- to be less defined than the Demand
337
338 evalStrictness (WwLazy _) _   = False
339 evalStrictness WwStrict   val = isBot val
340 evalStrictness WwEnum     val = isBot val
341
342 evalStrictness (WwUnpack NewType _ (demand:_)) val
343   = evalStrictness demand val
344
345 evalStrictness (WwUnpack DataType _ demand_info) val
346   = case val of
347       AbsTop       -> False
348       AbsBot       -> True
349       AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
350       _            -> trace "evalStrictness?" False
351
352 evalStrictness WwPrim val
353   = case val of
354       AbsTop -> False
355
356       other  ->   -- A primitive value should be defined, never bottom;
357                   -- hence this paranoia check
358                 pprPanic "evalStrictness: WwPrim:" (ppr other)
359 \end{code}
360
361 For absence analysis, we're interested in whether "poison" in the
362 argument (ie a bottom therein) can propagate to the result of the
363 function call; that is, whether the specified demand can {\em
364 possibly} hit poison.
365
366 \begin{code}
367 evalAbsence (WwLazy True) _ = False     -- Can't possibly hit poison
368                                         -- with Absent demand
369
370 evalAbsence (WwUnpack NewType _ (demand:_)) val
371   = evalAbsence demand val
372
373 evalAbsence (WwUnpack DataType _ demand_info) val
374   = case val of
375         AbsTop       -> False           -- No poison in here
376         AbsBot       -> True            -- Pure poison
377         AbsProd vals -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
378         _            -> panic "evalAbsence: other"
379
380 evalAbsence other val = anyBot val
381   -- The demand is conservative; even "Lazy" *might* evaluate the
382   -- argument arbitrarily so we have to look everywhere for poison
383 \end{code}
384
385 %************************************************************************
386 %*                                                                      *
387 \subsection[absEval]{Evaluate an expression in the abstract domain}
388 %*                                                                      *
389 %************************************************************************
390
391 \begin{code}
392 -- The isBottomingId stuf is now dealt with via the Id's strictness info
393 -- absId anal var env | isBottomingId var
394 --   = case anal of
395 --      StrAnal -> AbsBot       -- See discussion below
396 --      AbsAnal -> AbsTop       -- Just want to see if there's any poison in
397                                 -- error's arg
398
399 absId anal var env
400   = let
401      result =
402       case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of
403
404         (Just abs_val, _, _) ->
405                         abs_val -- Bound in the environment
406
407         (Nothing, NoStrictnessInfo, CoreUnfolding _ _ unfolding) ->
408                         -- We have an unfolding for the expr
409                         -- Assume the unfolding has no free variables since it
410                         -- came from inside the Id
411                         absEval anal (unTagBinders unfolding) env
412                 -- Notice here that we only look in the unfolding if we don't
413                 -- have strictness info (an unusual situation).
414                 -- We could have chosen to look in the unfolding if it exists,
415                 -- and only try the strictness info if it doesn't, and that would
416                 -- give more accurate results, at the cost of re-abstract-interpreting
417                 -- the unfolding every time.
418                 -- We found only one place where the look-at-unfolding-first
419                 -- method gave better results, which is in the definition of
420                 -- showInt in the Prelude.  In its defintion, fromIntegral is
421                 -- not inlined (it's big) but ab-interp-ing its unfolding gave
422                 -- a better result than looking at its strictness only.
423                 --  showInt :: Integral a => a -> [Char] -> [Char]
424                 -- !       {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
425                 --         "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-}
426                 -- --- 42,44 ----
427                 --   showInt :: Integral a => a -> [Char] -> [Char]
428                 -- !       {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
429                 --        "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
430
431
432         (Nothing, strictness_info, _) ->
433                         -- Includes MagicUnfolding, NoUnfolding
434                         -- Try the strictness info
435                         absValFromStrictness anal strictness_info
436     in
437     -- pprTrace "absId:" (hcat [ppr var, ptext SLIT("=:"), pp_anal anal, text SLIT(":="),ppr result]) $
438     result
439   where
440     pp_anal StrAnal = ptext SLIT("STR")
441     pp_anal AbsAnal = ptext SLIT("ABS")
442
443 absEvalAtom anal (VarArg v) env = absId anal v env
444 absEvalAtom anal (LitArg _) env = AbsTop
445 \end{code}
446
447 \begin{code}
448 absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
449
450 absEval anal (Var var) env = absId anal var env
451
452 absEval anal (Lit _) env = AbsTop
453     -- What if an unboxed literal?  That's OK: it terminates, so its
454     -- abstract value is AbsTop.
455
456     -- For absence analysis, a literal certainly isn't the "poison" variable
457 \end{code}
458
459 Discussion about \tr{error} (following/quoting Lennart): Any expression
460 \tr{error e} is regarded as bottom (with HBC, with the
461 \tr{-ffail-strict} flag, on with \tr{-O}).
462
463 Regarding it as bottom gives much better strictness properties for
464 some functions.  E.g.
465 \begin{verbatim}
466         f [x] y = x+y
467         f (x:xs) y = f xs (x+y)
468 i.e.
469         f [] _ = error "no match"
470         f [x] y = x+y
471         f (x:xs) y = f xs (x+y)
472 \end{verbatim}
473 is strict in \tr{y}, which you really want.  But, it may lead to
474 transformations that turn a call to \tr{error} into non-termination.
475 (The odds of this happening aren't good.)
476
477
478 Things are a little different for absence analysis, because we want
479 to make sure that any poison (?????)
480
481 \begin{code}
482 absEval StrAnal (Prim SeqOp [TyArg _, e]) env
483   = ASSERT(isValArg e)
484     if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
485         -- This is a special case to ensure that seq# is strict in its argument.
486         -- The comments below (for most normal PrimOps) do not apply.
487
488 absEval StrAnal (Prim op es) env = AbsTop
489         -- The arguments are all of unboxed type, so they will already
490         -- have been eval'd.  If the boxed version was bottom, we'll
491         -- already have returned bottom.
492
493         -- Actually, I believe we are saying that either (1) the
494         -- primOp uses unboxed args and they've been eval'ed, so
495         -- there's no need to force strictness here, _or_ the primOp
496         -- uses boxed args and we don't know whether or not it's
497         -- strict, so we assume laziness. (JSM)
498
499 absEval AbsAnal (Prim op as) env
500   = if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
501     then AbsBot
502     else AbsTop
503         -- For absence analysis, we want to see if the poison shows up...
504
505 absEval anal (Con con as) env
506   | isProductTyCon (dataConTyCon con)
507   = --pprTrace "absEval.Con" (cat[ text "con: ", (ppr con), text "args: ", interppSP as]) $
508     AbsProd [absEvalAtom anal a env | a <- as, isValArg a]
509
510   | otherwise   -- Not single-constructor
511   = case anal of
512         StrAnal ->      -- Strictness case: it's easy: it certainly terminates
513                    AbsTop
514         AbsAnal ->      -- In the absence case we need to be more
515                         -- careful: look to see if there's any
516                         -- poison in the components
517                    if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
518                    then AbsBot
519                    else AbsTop
520 \end{code}
521
522 \begin{code}
523 absEval anal (Lam (ValBinder binder) body) env
524   = AbsFun binder body env
525 absEval anal (Lam other_binder expr) env
526   = absEval  anal expr env
527 absEval anal (App f a) env | isValArg a
528   = absApply anal (absEval anal f env) (absEvalAtom anal a env)
529 absEval anal (App expr _) env
530   = absEval anal expr env
531 \end{code}
532
533 For primitive cases, just GLB the branches, then LUB with the expr part.
534
535 \begin{code}
536 absEval anal (Case expr (PrimAlts alts deflt)) env
537   = let
538         expr_val    = absEval anal expr env
539         abs_alts    = [ absEval anal rhs env | (_, rhs) <- alts ]
540                         -- PrimAlts don't bind anything, so no need
541                         -- to extend the environment
542
543         abs_deflt   = absEvalDefault anal expr_val deflt env
544     in
545         combineCaseValues anal expr_val
546                                (abs_deflt ++ abs_alts)
547
548 absEval anal (Case expr (AlgAlts alts deflt)) env
549   = let
550         expr_val  = absEval anal expr env
551         abs_alts  = [ absEvalAlgAlt anal expr_val alt env | alt <- alts ]
552         abs_deflt = absEvalDefault anal expr_val deflt env
553     in
554     let
555         result =
556           combineCaseValues anal expr_val
557                                 (abs_deflt ++ abs_alts)
558     in
559 {-
560     (case anal of
561         StrAnal -> id
562         _ -> pprTrace "absCase:ABS:" (($$) (hsep [ppr expr, ppr result, ppr expr_val, ppr abs_deflt, ppr abs_alts]) (ppr (keysFM env `zip` eltsFM env)))
563     )
564 -}
565     result
566 \end{code}
567
568 For @Lets@ we widen the value we get.  This is nothing to
569 do with fixpointing.  The reason is so that we don't get an explosion
570 in the amount of computation.  For example, consider:
571 \begin{verbatim}
572       let
573         g a = case a of
574                 q1 -> ...
575                 q2 -> ...
576         f x = case x of
577                 p1 -> ...g r...
578                 p2 -> ...g s...
579       in
580         f e
581 \end{verbatim}
582 If we bind @f@ and @g@ to their exact abstract value, then we'll
583 ``execute'' one call to @f@ and {\em two} calls to @g@.  This can blow
584 up exponentially.  Widening cuts it off by making a fixed
585 approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are
586 not evaluated again at all when they are called.
587
588 Of course, this can lose useful joint strictness, which is sad.  An
589 alternative approach would be to try with a certain amount of ``fuel''
590 and be prepared to bale out.
591
592 \begin{code}
593 absEval anal (Let (NonRec binder e1) e2) env
594   = let
595         new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
596     in
597         -- The binder of a NonRec should *not* be of unboxed type,
598         -- hence no need to strictly evaluate the Rhs.
599     absEval anal e2 new_env
600
601 absEval anal (Let (Rec pairs) body) env
602   = let
603         (binders,rhss) = unzip pairs
604         rhs_vals = cheapFixpoint anal binders rhss env  -- Returns widened values
605         new_env  = growAbsValEnvList env (binders `zip` rhs_vals)
606     in
607     absEval anal body new_env
608
609 absEval anal (Note note expr) env = absEval anal expr env
610 \end{code}
611
612 \begin{code}
613 absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],CoreExpr) -> AbsValEnv -> AbsVal
614
615 absEvalAlgAlt anal (AbsProd arg_vals) (con, args, rhs) env
616   =     -- The scrutinee is a product value, so it must be of a single-constr
617         -- type; so the constructor in this alternative must be the right one
618         -- so we can go ahead and bind the constructor args to the components
619         -- of the product value.
620     ASSERT(length arg_vals == length args)
621     let
622          new_env = growAbsValEnvList env (args `zip` arg_vals)
623     in
624     absEval anal rhs new_env
625
626 absEvalAlgAlt anal other_scrutinee (con, args, rhs) env
627   =     -- Scrutinised value is Top or Bot (it can't be a function!)
628         -- So just evaluate the rhs with all constr args bound to Top.
629         -- (If the scrutinee is Top we'll never evaluated this function
630         -- call anyway!)
631     ASSERT(ok_scrutinee)
632     absEval anal rhs rhs_env
633   where
634     rhs_env = growAbsValEnvList env (args `zip` repeat AbsTop)
635                 -- We must extend the environment, because
636                 -- there might be shadowing
637
638     ok_scrutinee
639       = case other_scrutinee of {
640           AbsTop -> True;   -- i.e., OK
641           AbsBot -> True;   -- ditto
642           _      -> False   -- party over
643         }
644
645
646 absEvalDefault :: AnalysisKind
647                -> AbsVal                -- Value of scrutinee
648                -> CoreCaseDefault
649                -> AbsValEnv
650                -> [AbsVal]              -- Empty or singleton
651
652 absEvalDefault anal scrut_val NoDefault env = []
653 absEvalDefault anal scrut_val (BindDefault binder expr) env
654   = [absEval anal expr (addOneToAbsValEnv env binder scrut_val)]
655 \end{code}
656
657 %************************************************************************
658 %*                                                                      *
659 \subsection[absApply]{Apply an abstract function to an abstract argument}
660 %*                                                                      *
661 %************************************************************************
662
663 Easy ones first:
664
665 \begin{code}
666 absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal
667
668 absApply anal AbsBot arg = AbsBot
669   -- AbsBot represents the abstract bottom *function* too
670
671 absApply StrAnal AbsTop arg = AbsTop
672 absApply AbsAnal AbsTop arg = if anyBot arg
673                               then AbsBot
674                               else AbsTop
675         -- To be conservative, we have to assume that a function about
676         -- which we know nothing (AbsTop) might look at some part of
677         -- its argument
678 \end{code}
679
680 An @AbsFun@ with only one more argument needed---bind it and eval the
681 result.  A @Lam@ with two or more args: return another @AbsFun@ with
682 an augmented environment.
683
684 \begin{code}
685 absApply anal (AbsFun binder body env) arg
686   = absEval anal body (addOneToAbsValEnv env binder arg)
687 \end{code}
688
689 \begin{code}
690 absApply StrAnal (AbsApproxFun demand val) arg
691   = if evalStrictness demand arg
692     then AbsBot
693     else val
694
695 absApply AbsAnal (AbsApproxFun demand val) arg
696   = if evalAbsence demand arg
697     then AbsBot
698     else val
699
700 #ifdef DEBUG
701 absApply anal f@(AbsProd _)       arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
702 #endif
703 \end{code}
704
705
706
707
708 %************************************************************************
709 %*                                                                      *
710 \subsection[findStrictness]{Determine some binders' strictness}
711 %*                                                                      *
712 %************************************************************************
713
714 @findStrictness@ applies the function \tr{\ ids -> expr} to
715 \tr{[bot,top,top,...]}, \tr{[top,bot,top,top,...]}, etc., (i.e., once
716 with @AbsBot@ in each argument position), and evaluates the resulting
717 abstract value; it returns a vector of @Demand@s saying whether the
718 result of doing this is guaranteed to be bottom.  This tells the
719 strictness of the function in each of the arguments.
720
721 If an argument is of unboxed type, then we declare that function to be
722 strict in that argument.
723
724 We don't really have to make up all those lists of mostly-@AbsTops@;
725 unbound variables in an @AbsValEnv@ are implicitly mapped to that.
726
727 See notes on @addStrictnessInfoToId@.
728
729 \begin{code}
730 findStrictness :: [Type]        -- Types of args in which strictness is wanted
731                -> AbsVal        -- Abstract strictness value of function
732                -> AbsVal        -- Abstract absence value of function
733                -> [Demand]      -- Resulting strictness annotation
734
735 findStrictness [] str_val abs_val = []
736
737 findStrictness (ty:tys) str_val abs_val
738   = let
739         demand       = findRecDemand str_fn abs_fn ty
740         str_fn val   = absApply StrAnal str_val val
741         abs_fn val   = absApply AbsAnal abs_val val
742
743         demands = findStrictness tys
744                         (absApply StrAnal str_val AbsTop)
745                         (absApply AbsAnal abs_val AbsTop)
746     in
747     demand : demands
748 \end{code}
749
750
751 \begin{code}
752 findDemandStrOnly str_env expr binder   -- Only strictness environment available
753   = findRecDemand str_fn abs_fn (idType binder)
754   where
755     str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
756     abs_fn val = AbsBot         -- Always says poison; so it looks as if
757                                 -- nothing is absent; safe
758
759 findDemandAbsOnly abs_env expr binder   -- Only absence environment available
760   = findRecDemand str_fn abs_fn (idType binder)
761   where
762     str_fn val = AbsBot         -- Always says non-termination;
763                                 -- that'll make findRecDemand peer into the
764                                 -- structure of the value.
765     abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
766
767
768 findDemand str_env abs_env expr binder
769   = findRecDemand str_fn abs_fn (idType binder)
770   where
771     str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
772     abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
773 \end{code}
774
775 @findRecDemand@ is where we finally convert strictness/absence info
776 into ``Demands'' which we can pin on Ids (etc.).
777
778 NOTE: What do we do if something is {\em both} strict and absent?
779 Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all
780 strict (because of bottoming effect of \tr{error}) or all absent
781 (because they're not used)?
782
783 Well, for practical reasons, we prefer absence over strictness.  In
784 particular, it makes the ``default defaults'' for class methods (the
785 ones that say \tr{defm.foo dict = error "I don't exist"}) come out
786 nicely [saying ``the dict isn't used''], rather than saying it is
787 strict in every component of the dictionary [massive gratuitious
788 casing to take the dict apart].
789
790 But you could have examples where going for strictness would be better
791 than absence.  Consider:
792 \begin{verbatim}
793         let x = something big
794         in
795         f x y z + g x
796 \end{verbatim}
797
798 If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is
799 lazy, then the thunk for \tr{x} will be built.  If \tr{f} was strict,
800 then we'd let-to-case it:
801 \begin{verbatim}
802         case something big of
803           x -> f x y z + g x
804 \end{verbatim}
805 Ho hum.
806
807 \begin{code}
808 findRecDemand :: (AbsVal -> AbsVal) -- The strictness function
809               -> (AbsVal -> AbsVal) -- The absence function
810               -> Type       -- The type of the argument
811               -> Demand
812
813 findRecDemand str_fn abs_fn ty
814   = if isUnpointedType ty then -- It's a primitive type!
815        wwPrim
816
817     else if not (anyBot (abs_fn AbsBot)) then -- It's absent
818        -- We prefer absence over strictness: see NOTE above.
819        WwLazy True
820
821     else if not (opt_AllStrict ||
822                 (opt_NumbersStrict && is_numeric_type ty) ||
823                 (isBot (str_fn AbsBot))) then
824         WwLazy False -- It's not strict and we're not pretending
825
826     else -- It's strict (or we're pretending it is)!
827
828        case (splitAlgTyConApp_maybe ty) of
829
830          Nothing    -> wwStrict
831
832          Just (tycon,tycon_arg_tys,[data_con]) | isProductTyCon tycon ->
833            -- Non-recursive, single constructor case
834            let
835               cmpnt_tys = dataConArgTys data_con tycon_arg_tys
836               prod_len = length cmpnt_tys
837            in
838
839            if isNewTyCon tycon then     -- A newtype!
840                 ASSERT( null (tail cmpnt_tys) )
841                 let
842                     demand = findRecDemand str_fn abs_fn (head cmpnt_tys)
843                 in
844                 case demand of          -- No point in unpacking unless there is more to see inside
845                   WwUnpack _ _ _ -> wwUnpackNew demand
846                   other          -> wwStrict 
847
848            else                         -- A data type!
849            let
850               compt_strict_infos
851                 = [ findRecDemand
852                          (\ cmpnt_val ->
853                                str_fn (mkMainlyTopProd prod_len i cmpnt_val)
854                          )
855                          (\ cmpnt_val ->
856                                abs_fn (mkMainlyTopProd prod_len i cmpnt_val)
857                          )
858                      cmpnt_ty
859                   | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
860            in
861            if null compt_strict_infos then
862                  if isEnumerationTyCon tycon then wwEnum else wwStrict
863            else
864                  wwUnpackData compt_strict_infos
865
866          Just (tycon,_,_) ->
867                 -- Multi-constr data types, *or* an abstract data
868                 -- types, *or* things we don't have a way of conveying
869                 -- the info over module boundaries (class ops,
870                 -- superdict sels, dfns).
871             if isEnumerationTyCon tycon then
872                 wwEnum
873             else
874                 wwStrict
875   where
876     is_numeric_type ty
877       = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above
878           Nothing -> False
879           Just (tycon, _, _)
880             | tycon `is_elem`
881               [intTyCon, integerTyCon,
882                doubleTyCon, floatTyCon,
883                wordTyCon, addrTyCon]
884             -> True
885           _{-something else-} -> False
886       where
887         is_elem = isIn "is_numeric_type"
888
889     -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of
890     -- them) except for a given value in the "i"th position.
891
892     mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal
893
894     mkMainlyTopProd n i val
895       = let
896             befores = nOfThem (i-1) AbsTop
897             afters  = nOfThem (n-i) AbsTop
898         in
899         AbsProd (befores ++ (val : afters))
900 \end{code}
901
902 %************************************************************************
903 %*                                                                      *
904 \subsection[fixpoint]{Fixpointer for the strictness analyser}
905 %*                                                                      *
906 %************************************************************************
907
908 The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an
909 environment, and returns the abstract value of each binder.
910
911 The @cheapFixpoint@ function makes a conservative approximation,
912 by binding each of the variables to Top in their own right hand sides.
913 That allows us to make rapid progress, at the cost of a less-than-wonderful
914 approximation.
915
916 \begin{code}
917 cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
918
919 cheapFixpoint AbsAnal [id] [rhs] env
920   = [crudeAbsWiden (absEval AbsAnal rhs new_env)]
921   where
922     new_env = addOneToAbsValEnv env id AbsTop   -- Unsafe starting point!
923                     -- In the just-one-binding case, we guarantee to
924                     -- find a fixed point in just one iteration,
925                     -- because we are using only a two-point domain.
926                     -- This improves matters in cases like:
927                     --
928                     --  f x y = letrec g = ...g...
929                     --          in g x
930                     --
931                     -- Here, y isn't used at all, but if g is bound to
932                     -- AbsBot we simply get AbsBot as the next
933                     -- iteration too.
934
935 cheapFixpoint anal ids rhss env
936   = [widen anal (absEval anal rhs new_env) | rhs <- rhss]
937                 -- We do just one iteration, starting from a safe
938                 -- approximation.  This won't do a good job in situations
939                 -- like:
940                 --      \x -> letrec f = ...g...
941                 --                   g = ...f...x...
942                 --            in
943                 --            ...f...
944                 -- Here, f will end up bound to Top after one iteration,
945                 -- and hence we won't spot the strictness in x.
946                 -- (A second iteration would solve this.  ToDo: try the effect of
947                 --  really searching for a fixed point.)
948   where
949     new_env = growAbsValEnvList env [(id,safe_val) | id <- ids]
950
951     safe_val
952       = case anal of    -- The safe starting point
953           StrAnal -> AbsTop
954           AbsAnal -> AbsBot
955 \end{code}
956
957 \begin{verbatim}
958 mkLookupFun :: (key -> key -> Bool)     -- Equality predicate
959             -> (key -> key -> Bool)     -- Less-than predicate
960             -> [(key,val)]              -- The assoc list
961             -> key                      -- The key
962             -> Maybe val                -- The corresponding value
963
964 mkLookupFun eq lt alist s
965   = case [a | (s',a) <- alist, s' `eq` s] of
966       []    -> Nothing
967       (a:_) -> Just a
968 \end{verbatim}
969
970 \begin{code}
971 fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
972
973 fixpoint anal [] _ env = []
974
975 fixpoint anal ids rhss env
976   = fix_loop initial_vals
977   where
978     initial_val id
979       = case anal of    -- The (unsafe) starting point
980           StrAnal -> if (returnsRealWorld (idType id))
981                      then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
982                      else AbsBot
983           AbsAnal -> AbsTop
984
985     initial_vals = [ initial_val id | id <- ids ]
986
987     fix_loop :: [AbsVal] -> [AbsVal]
988
989     fix_loop current_widened_vals
990       = let
991             new_env  = growAbsValEnvList env (ids `zip` current_widened_vals)
992             new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
993             new_widened_vals = map (widen anal) new_vals
994         in
995         if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
996             current_widened_vals
997
998             -- NB: I was too chicken to make that a zipWithEqual,
999             -- lest I jump into a black hole.  WDP 96/02
1000
1001             -- Return the widened values.  We might get a slightly
1002             -- better value by returning new_vals (which we used to
1003             -- do, see below), but alas that means that whenever the
1004             -- function is called we have to re-execute it, which is
1005             -- expensive.
1006
1007             -- OLD VERSION
1008             -- new_vals
1009             -- Return the un-widened values which may be a bit better
1010             -- than the widened ones, and are guaranteed safe, since
1011             -- they are one iteration beyond current_widened_vals,
1012             -- which itself is a fixed point.
1013         else
1014             fix_loop new_widened_vals
1015 \end{code}
1016
1017 For absence analysis, we make do with a very very simple approach:
1018 look for convergence in a two-point domain.
1019
1020 We used to use just one iteration, starting with the variables bound
1021 to @AbsBot@, which is safe.
1022
1023 Prior to that, we used one iteration starting from @AbsTop@ (which
1024 isn't safe).  Why isn't @AbsTop@ safe?  Consider:
1025 \begin{verbatim}
1026         letrec
1027           x = ...p..d...
1028           d = (x,y)
1029         in
1030         ...
1031 \end{verbatim}
1032 Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed
1033 point'' of @d@ being @(AbsTop, AbsTop)@!  An @AbsBot@ initial value is
1034 safe because it gives poison more often than really necessary, and
1035 thus may miss some absence, but will never claim absence when it ain't
1036 so.
1037
1038 Anyway, one iteration starting with everything bound to @AbsBot@ give
1039 bad results for
1040
1041         f = \ x -> ...f...
1042
1043 Here, f would always end up bound to @AbsBot@, which ain't very
1044 clever, because then it would introduce poison whenever it was
1045 applied.  Much better to start with f bound to @AbsTop@, and widen it
1046 to @AbsBot@ if any poison shows up. In effect we look for convergence
1047 in the two-point @AbsTop@/@AbsBot@ domain.
1048
1049 What we miss (compared with the cleverer strictness analysis) is
1050 spotting that in this case
1051
1052         f = \ x y -> ...y...(f x y')...
1053
1054 \tr{x} is actually absent, since it is only passed round the loop, never
1055 used.  But who cares about missing that?
1056
1057 NB: despite only having a two-point domain, we may still have many
1058 iterations, because there are several variables involved at once.