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