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