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