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