ghc/compiler/stranal/SaAbsInt.lhs

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