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