ghc/compiler/stranal/SaAbsInt.lhs

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