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