SaAbsInt.lhs 34 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
3
4
5
6
7
8
9
10
11
12
13
14
15
%
\section[SaAbsInt]{Abstract interpreter for strictness analysis}

\begin{code}
module SaAbsInt (
	findStrictness,
	findDemand,
	absEval,
	widen,
	fixpoint,
	isBot
    ) where

16
#include "HsVersions.h"
17

sof's avatar
sof committed
18
import CmdLineOpts	( opt_AllStrict, opt_NumbersStrict )
19
import CoreSyn
20
import CoreUnfold	( Unfolding(..), FormSummary )
21
22
import CoreUtils	( unTagBinders )
import Id		( idType, getIdStrictness, getIdUnfolding,
23
			  dataConTyCon, dataConArgTys, Id
24
			)
sof's avatar
sof committed
25
26
import IdInfo		( StrictnessInfo(..) )
import Demand		( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwUnpackNew )
27
28
29
import MagicUFs		( MagicUnfoldingFun )
import Maybes		( maybeToBool )
import PrimOp		( PrimOp(..) )
30
import SaLib
31
import TyCon		( isProductTyCon, isEnumerationTyCon, isNewTyCon, 
32
33
			  TyCon{-instance Eq-}
			)
sof's avatar
sof committed
34
import BasicTypes	( NewOrData(..) )
35
36
import Type		( splitAlgTyConApp_maybe, 
		          isUnpointedType, Type )
37
38
39
import TysWiredIn	( intTyCon, integerTyCon, doubleTyCon,
			  floatTyCon, wordTyCon, addrTyCon
			)
sof's avatar
sof committed
40
import Util		( isIn, isn'tIn, nOfThem, zipWithEqual, trace )
41
import Outputable	
42

43
returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)"
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
\end{code}

%************************************************************************
%*									*
\subsection[AbsVal-ops]{Operations on @AbsVals@}
%*									*
%************************************************************************

Least upper bound, greatest lower bound.

\begin{code}
lub, glb :: AbsVal -> AbsVal -> AbsVal

lub val1 val2 | isBot val1    = val2	-- The isBot test includes the case where
lub val1 val2 | isBot val2    = val1	-- one of the val's is a function which
					-- always returns bottom, such as \y.x,
					-- when x is bound to bottom.

62
lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
63
64

lub _		  _	      = AbsTop	-- Crude, but conservative
65
					-- The crudity only shows up if there
66
67
68
69
70
71
72
73
74
75
					-- are functions involved

-- Slightly funny glb; for absence analysis only;
-- AbsBot is the safe answer.
--
-- Using anyBot rather than just testing for AbsBot is important.
-- Consider:
--
--   f = \a b -> ...
--
76
--   g = \x y z -> case x of
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
--	  	     []     -> f x
--		     (p:ps) -> f p
--
-- Now, the abstract value of the branches of the case will be an
-- AbsFun, but when testing for z's absence we want to spot that it's
-- an AbsFun which can't possibly return AbsBot.  So when glb'ing we
-- mustn't be too keen to bale out and return AbsBot; the anyBot test
-- spots that (f x) can't possibly return AbsBot.

-- We have also tripped over the following interesting case:
--	case x of
--	  []     -> \y -> 1
--        (p:ps) -> f
--
-- Now, suppose f is bound to AbsTop.  Does this expression mention z?
-- Obviously not.  But the case will take the glb of AbsTop (for f) and
-- an AbsFun (for \y->1). We should not bale out and give AbsBot, because
-- that would say that it *does* mention z (or anything else for that matter).
-- Nor can we always return AbsTop, because the AbsFun might be something
-- like (\y->z), which obviously does mention z. The point is that we're
-- glbing two functions, and AbsTop is not actually the top of the function
-- lattice.  It is more like (\xyz -> x|y|z); that is, AbsTop returns
-- poison iff any of its arguments do.

-- Deal with functions specially, because AbsTop isn't the
-- top of their domain.

104
glb v1 v2
105
  | is_fun v1 || is_fun v2
106
  = if not (anyBot v1) && not (anyBot v2)
107
108
109
110
111
    then
	AbsTop
    else
	AbsBot
  where
112
113
114
    is_fun (AbsFun _ _ _)     = True
    is_fun (AbsApproxFun _ _) = True	-- Not used, but the glb works ok
    is_fun other              = False
115
116
117

-- The non-functional cases are quite straightforward

118
glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys)
119
120
121
122
123
124
125
126

glb AbsTop	 v2	      = v2
glb v1           AbsTop	      = v1

glb _            _            = AbsBot 		-- Be pessimistic



127
combineCaseValues
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
	:: AnalysisKind
	-> AbsVal	-- Value of scrutinee
	-> [AbsVal]	-- Value of branches (at least one)
	-> AbsVal	-- Result

-- For strictness analysis, see if the scrutinee is bottom; if so
-- return bottom; otherwise, the lub of the branches.

combineCaseValues StrAnal AbsBot	  branches = AbsBot
combineCaseValues StrAnal other_scrutinee branches
	-- Scrutinee can only be AbsBot, AbsProd or AbsTop
  = ASSERT(ok_scrutinee)
    foldr1 lub branches
  where
    ok_scrutinee
      = case other_scrutinee of {
	  AbsTop    -> True; 	-- i.e., cool
	  AbsProd _ -> True; 	-- ditto
	  _ 	    -> False 	-- party over
147
	}
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162

-- For absence analysis, check if the scrutinee is all poison (isBot)
-- If so, return poison (AbsBot); otherwise, any nested poison will come
-- out from looking at the branches, so just glb together the branches
-- to get the worst one.

combineCaseValues AbsAnal AbsBot          branches = AbsBot
combineCaseValues AbsAnal other_scrutinee branches
	-- Scrutinee can only be AbsBot, AbsProd or AbsTop
  = ASSERT(ok_scrutinee)
    let
	result = foldr1 glb branches

	tracer = if at_least_one_AbsFun && at_least_one_AbsTop
		    && no_AbsBots then
163
		    pprTrace "combineCase:" (ppr branches)
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
		 else
		    id
    in
--    tracer (
    result
--    )
  where
    ok_scrutinee
      = case other_scrutinee of {
	  AbsTop    -> True; 	-- i.e., cool
	  AbsProd _ -> True; 	-- ditto
	  _ 	    -> False 	-- party over
	}

    at_least_one_AbsFun = foldr ((||) . is_AbsFun) False branches
    at_least_one_AbsTop = foldr ((||) . is_AbsTop) False branches
    no_AbsBots = foldr ((&&) . is_not_AbsBot) True branches

    is_AbsFun x = case x of { AbsFun _ _ _ -> True; _ -> False }
    is_AbsTop x = case x of { AbsTop -> True; _ -> False }
    is_not_AbsBot x = case x of { AbsBot -> False; _ -> True }
\end{code}

@isBot@ returns True if its argument is (a representation of) bottom.  The
``representation'' part is because we need to detect the bottom {\em function}
too.  To detect the bottom function, bind its args to top, and see if it
returns bottom.

Used only in strictness analysis:
\begin{code}
isBot :: AbsVal -> Bool

196
197
isBot AbsBot		    = True
isBot (AbsFun arg body env) = isBot (absEval StrAnal body env)
198
199
			       -- Don't bother to extend the envt because
			       -- unbound variables default to AbsTop anyway
200
isBot other	 	    = False
201
202
203
204
205
206
207
208
209
\end{code}

Used only in absence analysis:
\begin{code}
anyBot :: AbsVal -> Bool

anyBot AbsBot 		      = True	-- poisoned!
anyBot AbsTop 		      = False
anyBot (AbsProd vals) 	      = any anyBot vals
210
211
anyBot (AbsFun arg body env)  = anyBot (absEval AbsAnal body env)
anyBot (AbsApproxFun _ _)     = False
212
213
214
215
216
217
218
219
220
221
222
223
224

    -- AbsApproxFun can only arise in absence analysis from the Demand
    -- info of an imported value; whatever it is we're looking for is
    -- certainly not present over in the imported value.
\end{code}

@widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
approximated by $val$.  Furthermore, the result has no @AbsFun@s in
it, so it can be compared for equality by @sameVal@.

\begin{code}
widen :: AnalysisKind -> AbsVal -> AbsVal

225
226
227
228
229
230
231
232
233
widen StrAnal (AbsFun arg body env)
  = AbsApproxFun (findDemandStrOnly env body arg)
		 (widen StrAnal abs_body)
  where
    abs_body = absEval StrAnal body env

{-	OLD comment... 
	This stuff is now instead handled neatly by the fact that AbsApproxFun 
	contains an AbsVal inside it.	SLPJ Jan 97
234

235
  | isBot abs_body = AbsBot
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
    -- It's worth checking for a function which is unconditionally
    -- bottom.  Consider
    --
    --	f x y = let g y = case x of ...
    --		in (g ..) + (g ..)
    --
    -- Here, when we are considering strictness of f in x, we'll
    -- evaluate the body of f with x bound to bottom.  The current
    -- strategy is to bind g to its *widened* value; without the isBot
    -- (...) test above, we'd bind g to an AbsApproxFun, and deliver
    -- Top, not Bot as the value of f's rhs.  The test spots the
    -- unconditional bottom-ness of g when x is bottom.  (Another
    -- alternative here would be to bind g to its exact abstract
    -- value, but that entails lots of potential re-computation, at
    -- every application of g.)
251
-}
252

253
254
255
256
widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
widen StrAnal other_val	     = other_val


257
258
widen AbsAnal (AbsFun arg body env)
  | anyBot abs_body = AbsBot
259
260
261
262
263
	-- In the absence-analysis case it's *essential* to check
	-- that the function has no poison in its body.  If it does,
	-- anywhere, then the whole function is poisonous.

  | otherwise
264
265
266
267
  = AbsApproxFun (findDemandAbsOnly env body arg)
		 (widen AbsAnal abs_body)
  where
    abs_body = absEval AbsAnal body env
268

269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)

	-- It's desirable to do a good job of widening for product
	-- values.  Consider
	--
	--	let p = (x,y)
	--	in ...(case p of (x,y) -> x)...
	--
	-- Now, is y absent in this expression?  Currently the
	-- analyser widens p before looking at p's scope, to avoid
	-- lots of recomputation in the case where p is a function.
	-- So if widening doesn't have a case for products, we'll
	-- widen p to AbsBot (since when searching for absence in y we
	-- bind y to poison ie AbsBot), and now we are lost.

widen AbsAnal other_val = other_val

286
-- WAS:	  if anyBot val then AbsBot else AbsTop
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
-- Nowadays widen is doing a better job on functions for absence analysis.
\end{code}

@crudeAbsWiden@ is used just for absence analysis, and always
returns AbsTop or AbsBot, so it widens to a two-point domain

\begin{code}
crudeAbsWiden :: AbsVal -> AbsVal
crudeAbsWiden val = if anyBot val then AbsBot else AbsTop
\end{code}

@sameVal@ compares two abstract values for equality.  It can't deal with
@AbsFun@, but that should have been removed earlier in the day by @widen@.

\begin{code}
sameVal :: AbsVal -> AbsVal -> Bool	-- Can't handle AbsFun!

#ifdef DEBUG
sameVal (AbsFun _ _ _) _ = panic "sameVal: AbsFun: arg1"
sameVal _ (AbsFun _ _ _) = panic "sameVal: AbsFun: arg2"
#endif

sameVal AbsBot AbsBot = True
sameVal AbsBot other  = False	-- widen has reduced AbsFun bots to AbsBot

sameVal AbsTop AbsTop = True
sameVal AbsTop other  = False		-- Right?

315
sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2)
316
317
318
sameVal (AbsProd _)	AbsTop 		= False
sameVal (AbsProd _)	AbsBot 		= False

319
sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v2
320
321
sameVal (AbsApproxFun _ _)     AbsTop		      = False
sameVal (AbsApproxFun _ _)     AbsBot 		      = False
322
323
324
325
326
327
328
329
330
331

sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
\end{code}


@evalStrictness@ compares a @Demand@ with an abstract value, returning
@True@ iff the abstract value is {\em less defined} than the demand.
(@True@ is the exciting answer; @False@ is always safe.)

\begin{code}
332
333
334
evalStrictness :: Demand
	       -> AbsVal
	       -> Bool		-- True iff the value is sure
335
336
337
338
339
340
				-- to be less defined than the Demand

evalStrictness (WwLazy _) _   = False
evalStrictness WwStrict   val = isBot val
evalStrictness WwEnum	  val = isBot val

sof's avatar
sof committed
341
342
343
344
evalStrictness (WwUnpack NewType _ (demand:_)) val
  = evalStrictness demand val

evalStrictness (WwUnpack DataType _ demand_info) val
345
346
347
  = case val of
      AbsTop	   -> False
      AbsBot	   -> True
348
      AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
349
350
351
352
      _	    	   -> trace "evalStrictness?" False

evalStrictness WwPrim val
  = case val of
353
      AbsTop -> False
354

355
      other  ->   -- A primitive value should be defined, never bottom;
356
		  -- hence this paranoia check
357
		pprPanic "evalStrictness: WwPrim:" (ppr other)
358
359
360
361
362
363
364
365
\end{code}

For absence analysis, we're interested in whether "poison" in the
argument (ie a bottom therein) can propagate to the result of the
function call; that is, whether the specified demand can {\em
possibly} hit poison.

\begin{code}
366
evalAbsence (WwLazy True) _ = False	-- Can't possibly hit poison
367
368
					-- with Absent demand

sof's avatar
sof committed
369
370
371
372
evalAbsence (WwUnpack NewType _ (demand:_)) val
  = evalAbsence demand val

evalAbsence (WwUnpack DataType _ demand_info) val
373
374
375
  = case val of
	AbsTop	     -> False		-- No poison in here
	AbsBot 	     -> True		-- Pure poison
376
	AbsProd vals -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
	_	     -> panic "evalAbsence: other"

evalAbsence other val = anyBot val
  -- The demand is conservative; even "Lazy" *might* evaluate the
  -- argument arbitrarily so we have to look everywhere for poison
\end{code}

%************************************************************************
%*									*
\subsection[absEval]{Evaluate an expression in the abstract domain}
%*									*
%************************************************************************

\begin{code}
-- The isBottomingId stuf is now dealt with via the Id's strictness info
-- absId anal var env | isBottomingId var
--   = case anal of
--	StrAnal -> AbsBot 	-- See discussion below
--	AbsAnal -> AbsTop	-- Just want to see if there's any poison in
				-- error's arg

absId anal var env
  = let
     result =
      case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of

403
	(Just abs_val, _, _) ->
404
405
			abs_val	-- Bound in the environment

406
	(Nothing, NoStrictnessInfo, CoreUnfolding _ _ unfolding) ->
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
			-- We have an unfolding for the expr
			-- Assume the unfolding has no free variables since it
			-- came from inside the Id
			absEval anal (unTagBinders unfolding) env
		-- Notice here that we only look in the unfolding if we don't
		-- have strictness info (an unusual situation).
		-- We could have chosen to look in the unfolding if it exists,
		-- and only try the strictness info if it doesn't, and that would
		-- give more accurate results, at the cost of re-abstract-interpreting
		-- the unfolding every time.
		-- We found only one place where the look-at-unfolding-first
		-- method gave better results, which is in the definition of
		-- showInt in the Prelude.  In its defintion, fromIntegral is
		-- not inlined (it's big) but ab-interp-ing its unfolding gave
		-- a better result than looking at its strictness only.
		--  showInt :: Integral a => a -> [Char] -> [Char]
		-- !       {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
		--         "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-}
		-- --- 42,44 ----
		--   showInt :: Integral a => a -> [Char] -> [Char]
		-- !       {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
		--        "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}


431
	(Nothing, strictness_info, _) ->
432
			-- Includes MagicUnfolding, NoUnfolding
433
434
435
			-- Try the strictness info
			absValFromStrictness anal strictness_info
    in
436
    -- pprTrace "absId:" (hcat [ppr var, ptext SLIT("=:"), pp_anal anal, text SLIT(":="),ppr result]) $
437
438
    result
  where
sof's avatar
sof committed
439
440
    pp_anal StrAnal = ptext SLIT("STR")
    pp_anal AbsAnal = ptext SLIT("ABS")
441

442
443
absEvalAtom anal (VarArg v) env = absId anal v env
absEvalAtom anal (LitArg _) env = AbsTop
444
445
446
\end{code}

\begin{code}
447
absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
448

449
absEval anal (Var var) env = absId anal var env
450

451
absEval anal (Lit _) env = AbsTop
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
    -- What if an unboxed literal?  That's OK: it terminates, so its
    -- abstract value is AbsTop.

    -- For absence analysis, a literal certainly isn't the "poison" variable
\end{code}

Discussion about \tr{error} (following/quoting Lennart): Any expression
\tr{error e} is regarded as bottom (with HBC, with the
\tr{-ffail-strict} flag, on with \tr{-O}).

Regarding it as bottom gives much better strictness properties for
some functions.	 E.g.
\begin{verbatim}
	f [x] y = x+y
	f (x:xs) y = f xs (x+y)
i.e.
	f [] _ = error "no match"
	f [x] y = x+y
	f (x:xs) y = f xs (x+y)
\end{verbatim}
is strict in \tr{y}, which you really want.  But, it may lead to
transformations that turn a call to \tr{error} into non-termination.
(The odds of this happening aren't good.)


Things are a little different for absence analysis, because we want
to make sure that any poison (?????)

\begin{code}
481
482
483
absEval StrAnal (Prim SeqOp [TyArg _, e]) env
  = ASSERT(isValArg e)
    if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
484
485
486
	-- This is a special case to ensure that seq# is strict in its argument.
	-- The comments below (for most normal PrimOps) do not apply.

487
absEval StrAnal (Prim op es) env = AbsTop
488
489
490
491
492
493
494
495
496
497
	-- The arguments are all of unboxed type, so they will already
	-- have been eval'd.  If the boxed version was bottom, we'll
	-- already have returned bottom.

    	-- Actually, I believe we are saying that either (1) the
	-- primOp uses unboxed args and they've been eval'ed, so
	-- there's no need to force strictness here, _or_ the primOp
	-- uses boxed args and we don't know whether or not it's
    	-- strict, so we assume laziness. (JSM)

498
499
absEval AbsAnal (Prim op as) env
  = if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
500
501
502
503
    then AbsBot
    else AbsTop
	-- For absence analysis, we want to see if the poison shows up...

504
absEval anal (Con con as) env
505
506
  | isProductTyCon (dataConTyCon con)
  = --pprTrace "absEval.Con" (cat[ text "con: ", (ppr con), text "args: ", interppSP as]) $
sof's avatar
sof committed
507
    AbsProd [absEvalAtom anal a env | a <- as, isValArg a]
508
509
510
511

  | otherwise	-- Not single-constructor
  = case anal of
	StrAnal -> 	-- Strictness case: it's easy: it certainly terminates
512
513
		   AbsTop
	AbsAnal -> 	-- In the absence case we need to be more
514
515
			-- careful: look to see if there's any
			-- poison in the components
516
		   if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
517
518
519
520
521
		   then AbsBot
		   else AbsTop
\end{code}

\begin{code}
522
absEval anal (Lam (ValBinder binder) body) env
523
  = AbsFun binder body env
524
absEval anal (Lam other_binder expr) env
525
  = absEval  anal expr env
526
527
528
absEval anal (App f a) env | isValArg a
  = absApply anal (absEval anal f env) (absEvalAtom anal a env)
absEval anal (App expr _) env
529
  = absEval anal expr env
530
531
532
533
534
\end{code}

For primitive cases, just GLB the branches, then LUB with the expr part.

\begin{code}
535
absEval anal (Case expr (PrimAlts alts deflt)) env
536
537
538
  = let
	expr_val    = absEval anal expr env
	abs_alts    = [ absEval anal rhs env | (_, rhs) <- alts ]
539
540
			-- PrimAlts don't bind anything, so no need
			-- to extend the environment
541
542
543
544
545
546

	abs_deflt   = absEvalDefault anal expr_val deflt env
    in
	combineCaseValues anal expr_val
			       (abs_deflt ++ abs_alts)

547
absEval anal (Case expr (AlgAlts alts deflt)) env
548
  = let
549
	expr_val  = absEval anal expr env
550
551
552
553
554
555
556
557
558
559
560
	abs_alts  = [ absEvalAlgAlt anal expr_val alt env | alt <- alts ]
	abs_deflt = absEvalDefault anal expr_val deflt env
    in
    let
	result =
	  combineCaseValues anal expr_val
				(abs_deflt ++ abs_alts)
    in
{-
    (case anal of
	StrAnal -> id
561
	_ -> pprTrace "absCase:ABS:" (($$) (hsep [ppr expr, ppr result, ppr expr_val, ppr abs_deflt, ppr abs_alts]) (ppr (keysFM env `zip` eltsFM env)))
562
563
564
565
566
    )
-}
    result
\end{code}

567
For @Lets@ we widen the value we get.  This is nothing to
568
569
570
571
572
573
574
575
576
577
do with fixpointing.  The reason is so that we don't get an explosion
in the amount of computation.  For example, consider:
\begin{verbatim}
      let
	g a = case a of
		q1 -> ...
		q2 -> ...
	f x = case x of
		p1 -> ...g r...
		p2 -> ...g s...
578
      in
579
580
581
582
583
584
585
586
587
588
589
590
591
	f e
\end{verbatim}
If we bind @f@ and @g@ to their exact abstract value, then we'll
``execute'' one call to @f@ and {\em two} calls to @g@.  This can blow
up exponentially.  Widening cuts it off by making a fixed
approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are
not evaluated again at all when they are called.

Of course, this can lose useful joint strictness, which is sad.  An
alternative approach would be to try with a certain amount of ``fuel''
and be prepared to bale out.

\begin{code}
592
absEval anal (Let (NonRec binder e1) e2) env
593
594
595
  = let
	new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
    in
596
	-- The binder of a NonRec should *not* be of unboxed type,
597
598
599
	-- hence no need to strictly evaluate the Rhs.
    absEval anal e2 new_env

600
absEval anal (Let (Rec pairs) body) env
601
602
603
604
605
606
607
  = let
	(binders,rhss) = unzip pairs
	rhs_vals = cheapFixpoint anal binders rhss env	-- Returns widened values
	new_env  = growAbsValEnvList env (binders `zip` rhs_vals)
    in
    absEval anal body new_env

608
absEval anal (Note note expr) env = absEval anal expr env
609
610
611
\end{code}

\begin{code}
612
absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],CoreExpr) -> AbsValEnv -> AbsVal
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630

absEvalAlgAlt anal (AbsProd arg_vals) (con, args, rhs) env
  =	-- The scrutinee is a product value, so it must be of a single-constr
	-- type; so the constructor in this alternative must be the right one
	-- so we can go ahead and bind the constructor args to the components
	-- of the product value.
    ASSERT(length arg_vals == length args)
    let
	 new_env = growAbsValEnvList env (args `zip` arg_vals)
    in
    absEval anal rhs new_env

absEvalAlgAlt anal other_scrutinee (con, args, rhs) env
  = 	-- Scrutinised value is Top or Bot (it can't be a function!)
	-- So just evaluate the rhs with all constr args bound to Top.
	-- (If the scrutinee is Top we'll never evaluated this function
	-- call anyway!)
    ASSERT(ok_scrutinee)
631
    absEval anal rhs rhs_env
632
  where
633
634
635
636
    rhs_env = growAbsValEnvList env (args `zip` repeat AbsTop)
		-- We must extend the environment, because
		-- there might be shadowing

637
638
639
640
641
642
643
    ok_scrutinee
      = case other_scrutinee of {
	  AbsTop -> True;   -- i.e., OK
	  AbsBot -> True;   -- ditto
	  _ 	 -> False   -- party over
	}

644
645

absEvalDefault :: AnalysisKind
646
	       -> AbsVal		-- Value of scrutinee
647
648
	       -> CoreCaseDefault
	       -> AbsValEnv
649
650
	       -> [AbsVal]		-- Empty or singleton

651
652
absEvalDefault anal scrut_val NoDefault env = []
absEvalDefault anal scrut_val (BindDefault binder expr) env
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
  = [absEval anal expr (addOneToAbsValEnv env binder scrut_val)]
\end{code}

%************************************************************************
%*									*
\subsection[absApply]{Apply an abstract function to an abstract argument}
%*									*
%************************************************************************

Easy ones first:

\begin{code}
absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal

absApply anal AbsBot arg = AbsBot
  -- AbsBot represents the abstract bottom *function* too

absApply StrAnal AbsTop	arg = AbsTop
671
absApply AbsAnal AbsTop	arg = if anyBot arg
672
673
674
675
676
677
678
679
			      then AbsBot
			      else AbsTop
	-- To be conservative, we have to assume that a function about
	-- which we know nothing (AbsTop) might look at some part of
	-- its argument
\end{code}

An @AbsFun@ with only one more argument needed---bind it and eval the
680
result.	 A @Lam@ with two or more args: return another @AbsFun@ with
681
682
683
an augmented environment.

\begin{code}
684
absApply anal (AbsFun binder body env) arg
685
686
687
688
  = absEval anal body (addOneToAbsValEnv env binder arg)
\end{code}

\begin{code}
689
690
absApply StrAnal (AbsApproxFun demand val) arg
  = if evalStrictness demand arg
691
    then AbsBot
692
    else val
693

694
695
absApply AbsAnal (AbsApproxFun demand val) arg
  = if evalAbsence demand arg
696
    then AbsBot
697
    else val
698
699

#ifdef DEBUG
700
absApply anal f@(AbsProd _)       arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
#endif
\end{code}




%************************************************************************
%*									*
\subsection[findStrictness]{Determine some binders' strictness}
%*									*
%************************************************************************

@findStrictness@ applies the function \tr{\ ids -> expr} to
\tr{[bot,top,top,...]}, \tr{[top,bot,top,top,...]}, etc., (i.e., once
with @AbsBot@ in each argument position), and evaluates the resulting
abstract value; it returns a vector of @Demand@s saying whether the
result of doing this is guaranteed to be bottom.  This tells the
strictness of the function in each of the arguments.

If an argument is of unboxed type, then we declare that function to be
strict in that argument.

We don't really have to make up all those lists of mostly-@AbsTops@;
unbound variables in an @AbsValEnv@ are implicitly mapped to that.

See notes on @addStrictnessInfoToId@.

\begin{code}
sof's avatar
sof committed
729
findStrictness :: [Type]	-- Types of args in which strictness is wanted
730
	       -> AbsVal 	-- Abstract strictness value of function
731
732
733
	       -> AbsVal	-- Abstract absence value of function
	       -> [Demand]	-- Resulting strictness annotation

sof's avatar
sof committed
734
findStrictness [] str_val abs_val = []
735

sof's avatar
sof committed
736
findStrictness (ty:tys) str_val abs_val
737
  = let
738
	demand 	     = findRecDemand str_fn abs_fn ty
739
740
741
	str_fn val   = absApply StrAnal str_val val
	abs_fn val   = absApply AbsAnal abs_val val

sof's avatar
sof committed
742
	demands = findStrictness tys
743
744
			(absApply StrAnal str_val AbsTop)
			(absApply AbsAnal abs_val AbsTop)
745
746
747
748
749
750
751
    in
    demand : demands
\end{code}


\begin{code}
findDemandStrOnly str_env expr binder 	-- Only strictness environment available
752
  = findRecDemand str_fn abs_fn (idType binder)
753
754
755
756
757
758
  where
    str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
    abs_fn val = AbsBot		-- Always says poison; so it looks as if
				-- nothing is absent; safe

findDemandAbsOnly abs_env expr binder 	-- Only absence environment available
759
  = findRecDemand str_fn abs_fn (idType binder)
760
761
762
763
764
  where
    str_fn val = AbsBot		-- Always says non-termination;
				-- that'll make findRecDemand peer into the
				-- structure of the value.
    abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
765

766
767

findDemand str_env abs_env expr binder
768
  = findRecDemand str_fn abs_fn (idType binder)
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
  where
    str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
    abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
\end{code}

@findRecDemand@ is where we finally convert strictness/absence info
into ``Demands'' which we can pin on Ids (etc.).

NOTE: What do we do if something is {\em both} strict and absent?
Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all
strict (because of bottoming effect of \tr{error}) or all absent
(because they're not used)?

Well, for practical reasons, we prefer absence over strictness.  In
particular, it makes the ``default defaults'' for class methods (the
ones that say \tr{defm.foo dict = error "I don't exist"}) come out
nicely [saying ``the dict isn't used''], rather than saying it is
strict in every component of the dictionary [massive gratuitious
casing to take the dict apart].

But you could have examples where going for strictness would be better
than absence.  Consider:
\begin{verbatim}
	let x = something big
	in
	f x y z + g x
\end{verbatim}

If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is
lazy, then the thunk for \tr{x} will be built.  If \tr{f} was strict,
then we'd let-to-case it:
\begin{verbatim}
	case something big of
	  x -> f x y z + g x
\end{verbatim}
Ho hum.

\begin{code}
807
findRecDemand :: (AbsVal -> AbsVal) -- The strictness function
808
	      -> (AbsVal -> AbsVal) -- The absence function
809
	      -> Type 	    -- The type of the argument
810
811
	      -> Demand

812
813
findRecDemand str_fn abs_fn ty
  = if isUnpointedType ty then -- It's a primitive type!
814
815
816
817
818
819
       wwPrim

    else if not (anyBot (abs_fn AbsBot)) then -- It's absent
       -- We prefer absence over strictness: see NOTE above.
       WwLazy True

sof's avatar
sof committed
820
821
822
    else if not (opt_AllStrict ||
		(opt_NumbersStrict && is_numeric_type ty) ||
		(isBot (str_fn AbsBot))) then
823
	WwLazy False -- It's not strict and we're not pretending
824

825
    else -- It's strict (or we're pretending it is)!
826

827
       case (splitAlgTyConApp_maybe ty) of
828
829
830

	 Nothing    -> wwStrict

831
832
	 Just (tycon,tycon_arg_tys,[data_con]) | isProductTyCon tycon ->
	   -- Non-recursive, single constructor case
833
	   let
834
	      cmpnt_tys = dataConArgTys data_con tycon_arg_tys
835
	      prod_len = length cmpnt_tys
sof's avatar
sof committed
836
837
838
839
840
	   in

	   if isNewTyCon tycon then	-- A newtype!
		ASSERT( null (tail cmpnt_tys) )
		let
841
		    demand = findRecDemand str_fn abs_fn (head cmpnt_tys)
sof's avatar
sof committed
842
843
844
845
		in
		case demand of		-- No point in unpacking unless there is more to see inside
		  WwUnpack _ _ _ -> wwUnpackNew demand
		  other	         -> wwStrict 
846

sof's avatar
sof committed
847
848
	   else				-- A data type!
	   let
849
	      compt_strict_infos
850
		= [ findRecDemand
851
852
853
854
855
856
857
858
859
860
861
862
			 (\ cmpnt_val ->
			       str_fn (mkMainlyTopProd prod_len i cmpnt_val)
			 )
			 (\ cmpnt_val ->
			       abs_fn (mkMainlyTopProd prod_len i cmpnt_val)
			 )
		     cmpnt_ty
		  | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
	   in
	   if null compt_strict_infos then
		 if isEnumerationTyCon tycon then wwEnum else wwStrict
	   else
sof's avatar
sof committed
863
		 wwUnpackData compt_strict_infos
864
865
866
867
868
869
870
871
872
873
874

	 Just (tycon,_,_) ->
		-- Multi-constr data types, *or* an abstract data
		-- types, *or* things we don't have a way of conveying
		-- the info over module boundaries (class ops,
		-- superdict sels, dfns).
	    if isEnumerationTyCon tycon then
		wwEnum
	    else
		wwStrict
  where
875
    is_numeric_type ty
876
      = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above
877
878
879
880
881
882
883
884
885
886
887
	  Nothing -> False
	  Just (tycon, _, _)
	    | tycon `is_elem`
	      [intTyCon, integerTyCon,
	       doubleTyCon, floatTyCon,
	       wordTyCon, addrTyCon]
	    -> True
	  _{-something else-} -> False
      where
	is_elem = isIn "is_numeric_type"

888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
    -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of
    -- them) except for a given value in the "i"th position.

    mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal

    mkMainlyTopProd n i val
      = let
	    befores = nOfThem (i-1) AbsTop
	    afters  = nOfThem (n-i) AbsTop
    	in
	AbsProd (befores ++ (val : afters))
\end{code}

%************************************************************************
%*									*
\subsection[fixpoint]{Fixpointer for the strictness analyser}
%*									*
%************************************************************************

The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an
environment, and returns the abstract value of each binder.

The @cheapFixpoint@ function makes a conservative approximation,
by binding each of the variables to Top in their own right hand sides.
That allows us to make rapid progress, at the cost of a less-than-wonderful
approximation.

\begin{code}
916
cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937

cheapFixpoint AbsAnal [id] [rhs] env
  = [crudeAbsWiden (absEval AbsAnal rhs new_env)]
  where
    new_env = addOneToAbsValEnv env id AbsTop	-- Unsafe starting point!
		    -- In the just-one-binding case, we guarantee to
		    -- find a fixed point in just one iteration,
		    -- because we are using only a two-point domain.
		    -- This improves matters in cases like:
		    --
		    --	f x y = letrec g = ...g...
		    --		in g x
		    --
		    -- Here, y isn't used at all, but if g is bound to
		    -- AbsBot we simply get AbsBot as the next
		    -- iteration too.

cheapFixpoint anal ids rhss env
  = [widen anal (absEval anal rhs new_env) | rhs <- rhss]
		-- We do just one iteration, starting from a safe
		-- approximation.  This won't do a good job in situations
938
		-- like:
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
		--	\x -> letrec f = ...g...
		--		     g = ...f...x...
		--	      in
		--	      ...f...
		-- Here, f will end up bound to Top after one iteration,
		-- and hence we won't spot the strictness in x.
		-- (A second iteration would solve this.  ToDo: try the effect of
		--  really searching for a fixed point.)
  where
    new_env = growAbsValEnvList env [(id,safe_val) | id <- ids]

    safe_val
      = case anal of	-- The safe starting point
	  StrAnal -> AbsTop
	  AbsAnal -> AbsBot
\end{code}

\begin{verbatim}
mkLookupFun :: (key -> key -> Bool)	-- Equality predicate
	    -> (key -> key -> Bool)	-- Less-than predicate
	    -> [(key,val)] 		-- The assoc list
	    -> key 			-- The key
	    -> Maybe val		-- The corresponding value

mkLookupFun eq lt alist s
  = case [a | (s',a) <- alist, s' `eq` s] of
      []    -> Nothing
      (a:_) -> Just a
\end{verbatim}

\begin{code}
970
fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
971
972
973

fixpoint anal [] _ env = []

974
fixpoint anal ids rhss env
975
976
977
978
  = fix_loop initial_vals
  where
    initial_val id
      = case anal of	-- The (unsafe) starting point
979
	  StrAnal -> if (returnsRealWorld (idType id))
980
981
982
983
984
985
986
987
		     then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
		     else AbsBot
	  AbsAnal -> AbsTop

    initial_vals = [ initial_val id | id <- ids ]

    fix_loop :: [AbsVal] -> [AbsVal]

988
    fix_loop current_widened_vals
989
990
991
992
      = let
	    new_env  = growAbsValEnvList env (ids `zip` current_widened_vals)
	    new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
	    new_widened_vals = map (widen anal) new_vals
993
	in
994
995
996
	if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
	    current_widened_vals

997
998
999
	    -- NB: I was too chicken to make that a zipWithEqual,
	    -- lest I jump into a black hole.  WDP 96/02

1000
	    -- Return the widened values.  We might get a slightly
For faster browsing, not all history is shown. View entire blame