ghc/compiler/stranal/SaAbsInt.lhs

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