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