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