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