ghc/compiler/stranal/SaAbsInt.lhs

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