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