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